二つ目の宿題3

もっと簡単にならないかとやってみたらこんな風になりました。

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


Worksheets("特価").Activate
With Application
　　.ScreenUpdating = False
　　'対象ブックを選択
　　読み込むブック = _
　　Application.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
　　　　　　　　　　If n <= 2 Then x = 3000 Else x = Cells(1).CurrentR
egion.Rows.Count + 3
　　　　　　　　　　For j = 4 To x
　　　　　　　　　　　　nhTMP = _
　　　　　　　　　　　　ExecuteExcel4Macro(目的データ & "R" & j & "C" & i)
　　　　　　　　　　　　If n <= 2 And nhTMP = "0" Then Exit For
　　　　　　　　　　　　.Cells(j - 3, n) = nhTMP
　　　　　　　　　　Next j
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next i
　　　　Next n
　　End With
　　.ScreenUpdating = True
End With
End Sub