二つ目の宿題2

Excel4マクロとかいうのを使いまず初めにやったことはそれぞれのフィールド位置をあらかじめ調べて記述・・・また1番目と2番目のフィールドはデータが切れた所が終端なのでそこを検出して抜けていますが3番目、4番目はそうとは限らないので無駄ですが3000行まで読んでいます。

Sub 特価データを読み込む()
　　Dim 読み込むブック As String, 読み込むシート As String
　　Dim 目的データ As String, nhTMP As String
　　Dim nH As Long, TargetCol As Long, 個別データ() As Integer

Worksheets("特価").Activate
With Application
　　.ScreenUpdating = False
　　'対象ブックを選択
　　読み込むブック = _
　　.GetOpenFilename("Microsoft Excel ブック,*.xls")
　　If 読み込むブック = "False" Then Exit Sub

　　'ファイル名に[]を付ける
　　読み込むブック = _
　　Replace(読み込むブック, Dir(読み込むブック), "[" & Dir(読み込むブック) & "]")

　　目的データ = "'" & 読み込むブック & "登録データ" & "'!"
With ActiveSheet
　　For nH = 4 To 3000 'データの読み込み
　　　　nhTMP = _
　　　　ExecuteExcel4Macro(目的データ & "R" & nH & "C3") '3列目
　　　　If nhTMP = "0" Then Exit For 'データがなくなったら抜ける
　　　　.Cells(nH - 3, 1) = nhTMP 'アクティブシートに出力
　　Next nH
　　For nH = 4 To 3000 'データの読み込み
　　　　nhTMP = _
　　　　　　ExecuteExcel4Macro(目的データ & "R" & nH & "C6")'6列目
　　　　If nhTMP = "0" Then Exit For 'データがなくなったら抜ける
　　　　.Cells(nH - 3, 2) = nhTMP 'アクティブシートに出力
　　Next nH
　　For nH = 4 To 3000 'データの読み込み
　　　　nhTMP = _
　　　　　　ExecuteExcel4Macro(目的データ & "R" & nH & "C10") '10列目
　　　　.Cells(nH - 3, 3) = nhTMP 'アクティブシートに出力
　　Next nH
　　For nH = 4 To 3000 'データの読み込み
　　　　nhTMP = _
　　　　　　ExecuteExcel4Macro(目的データ & "R" & nH & "C12") '12列目
　　　　.Cells(nH - 3, 4) = nhTMP 'アクティブシートに出力
Next nH
End With
.ScreenUpdating = True
End With
End Sub

次はフィールド名を配列に入れてそのフィールドを探すやり方、なおフィールドが記述されている行は4行目ということは分かっているので"R4"と固定、そしてここでは3，4番目のフィールドの処理の「for」は既に読み込んでいる最終行を利用。

Sub 特価データを読み込む()
　　Dim 読み込むブック As String, 読み込むシート As String
　　Dim 目的データ As String, nhTMP As String
　　Dim nH As Long, TargetCol As Long, 個別データ() As Integer
　　Dim フィールド名(4) As String
　　フィールド名(1) = "認可番号"
　　フィールド名(2) = "登録品名"
　　フィールド名(3) = "仕切"
　　フィールド名(4) = "登録価格"

Worksheets("特価").Activate
With Application
　　.ScreenUpdating = False
　　'対象ブックを選択
　　読み込むブック = _
　　　　.GetOpenFilename("Microsoft Excel ブック,*.xls")
　　If 読み込むブック = "False" Then Exit Sub

　　'ファイル名に[]を付ける
　　読み込むブック = _
　　Replace(読み込むブック, Dir(読み込むブック), "[" & Dir(読み込むブック) & "]")

　　目的データ = "'" & 読み込むブック & "登録データ" & "'!"

With ActiveSheet
　　For n = 1 To UBound(フィールド名) - 2
　　　　For i = 1 To 256
　　　　If InStr(ExecuteExcel4Macro(目的データ & "R4C" & i), フィールド名(n)) Then
　　　　　　　　For j = 4 To 3000
　　　　　　　　nhTMP = _
　　　　　　　　　ExecuteExcel4Macro(目的データ & "R" & j & "C" & i)
　　　　　　　　If nhTMP = "0" Then Exit For
　　　　　　　　　.Cells(j - 3, n) = nhTMP
　　　　　　　　Next j
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　Next n

　　For n = 3 To UBound(フィールド名)
　　　　For i = 1 To 256
　　　　If InStr(ExecuteExcel4Macro(目的データ & "R4C" & i), フィール
ド名(n)) Then
　　　　　　　　For j = 4 To Cells(1).CurrentRegion.Rows.Count + 3
　　　　　　　　nhTMP = _
　　　　　　　　　　ExecuteExcel4Macro(目的データ & "R" & j & "C" & i)
　　　　　　　　　　.Cells(j - 3, n) = nhTMP
　　　　　　　　Next j
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　Next n
End With
　　　　.ScreenUpdating = True
End With
End Sub

次は Select Case文でやったもの

Sub 特価データを読み込む()
　　Dim 読み込むブック As String, 読み込むシート As String
　　Dim 目的データ As String, nhTMP As String
　　Dim nH As Long, TargetCol As Long, 個別データ() As Integer
　　Dim フィールド名(4) As String
　　フィールド名(1) = "認可番号"
　　フィールド名(2) = "登録品名"
　　フィールド名(3) = "仕切"
　　フィールド名(4) = "登録価格"

Worksheets("特価").Activate
With Application
　　.ScreenUpdating = False
　　'対象ブックを選択
　　読み込むブック = _
　　.GetOpenFilename("Microsoft Excel ブック,*.xls")
　　If 読み込むブック = "False" Then Exit Sub

　　'ファイル名に[]を付ける
　　読み込むブック = _
　　Replace(読み込むブック, Dir(読み込むブック), "[" & Dir(読み込むブック) & "]")

　　目的データ = "'" & 読み込むブック & "登録データ" & "'!"

With ActiveSheet
　　For n = 1 To UBound(フィールド名)
　　　　For i = 1 To 256
　　　　If InStr(ExecuteExcel4Macro(目的データ & "R4C" & i), フィールド名(n)) Then
　　　　　　Select Case n
　　　　　　　　Case Is <= 2
　　　　　　　　　　For j = 4 To 3000
　　　　　　　　　　nhTMP = _
　　　　　　　　　　ExecuteExcel4Macro(目的データ & "R" & j & "C" & i)
　　　　　　　　　　If nhTMP = "0" Then Exit For
　　　　　　　　　　　　.Cells(j - 3, n) = nhTMP
　　　　　　　　　　Next j
　　　　　　　　　　Exit For
　　　　　　　　Case Else
　　　　　　　　　　For j = 4 To Cells(1).CurrentRegion.Rows.Count + 3
　　　　　　　　　　nhTMP = _
　　　　　　　　　　ExecuteExcel4Macro(目的データ & "R" & j & "C" & i)
　　　　　　　　　　　　.Cells(j - 3, n) = nhTMP
　　　　　　　　　　Next j
　　　　　　　　　　Exit For
　　　　　　　　End Select
　　　　　　End If
　　　　Next i
　　Next n
End With
　　　　.ScreenUpdating = True
End With
End Sub

データを読み込むのはこれでいいかな。
もっと短くならないかしら、このあとにチェックするマクロを書かなくちゃならないのです。