シート毎にマクロでVOOKをしたい

質問

シート毎にマクロでVOOKをしたい

先日、こちらで回答を頂いたコードを用いて、顧客会社一覧から顧客個人名別の名簿を
を作成しようと思っております。
ですが、この名簿が「あ」～「わ」行まで各シートに分かれています。
コードを「あ」～「わ」行まで順に書いていく方法の他に、もう少し簡易的な方法は
ないかと思い、質問をしました。他にもやり方があればご教授ください。

＃シートは「あ」～「わ」まで分かれており、フォーマットは統一している
＃検索値（顧客個人名番号）は各シートのA列に設けている

/////////////////////////////////////////////////////////////////////////////////

Sub 一覧()
Dim Base As Workbook, Code As Workbook
Dim myrange As Range　'転記先の範囲
Dim i As Long
Dim strname As String　'顧客個人名
Dim vntSearch As Variant　'顧客個人番号
　　Set Base = Workbooks("転記元.xls")
　　Set Code = Workbooks("転記先.xls")
　　Set myrange = Base.Worksheets("転記元").Range("A4:AX5000")
Code.Worksheets("あ").Range("B2:F200").ClearContents
Code.Worksheets("い").Range("B2:F200").ClearContents
　　Do
'-------------------------------------------------------------------------------
'あ行
　　　　vntSearch = Code.Worksheets("あ").Cells(i + 2, 1).Value
　　　　If vntSearch = "" Then Exit Do
　　　　On Error Resume Next
　　　　strname = ""
　　　　strname = Application.WorksheetFunction.VLookup(vntSearch, myrange, 6, False)
　　　　On Error GoTo 0
　　　　If strname <> "" Then
　　　　　 Code.Worksheets("あ").Cells(i + 2, 2) = strname
　　　　End If
'-------------------------------------------------------------------------------
'い行
　　　　vntSearch = Code.Worksheets("い").Cells(i + 2, 1).Value
　　　　If vntSearch = "" Then Exit Do
　　　　On Error Resume Next
　　　　strname = ""
　　　　strname = Application.WorksheetFunction.VLookup(vntSearch, myrange, 6, False)
　　　　On Error GoTo 0
　　　　If strname <> "" Then
　　　　　 Code.Worksheets("い").Cells(i + 2, 2) = strname
　　　　End If
　　　　i = i + 1
　　Loop

↓↓↓この先　～「わ」までコードを書く以外に方法があるのかが知りたい↓↓↓

End Sub
/////////////////////////////////////////////////////////////////////////////////

回答No.2

keithin · ベストアンサー

＃先に余談
Do Loopの脱出条件が間違ってるんじゃないかな？
どのシートでも最初に""が現れたら，全体を脱出してしまうように見えます。

ご質問の本題。
アプローチ１：
普通にシートを巡回するだけに見えます。
codeのWorksheetsのIndexが例えば２番（左から数えて２枚目に合致）が「あ」で，Worksheets(Worksheets.count)が「ん」だとすれば

dim j, k
for j = 2 to worksheets.count
　code.worksheets(j).range("B2:B200").clearcontents

　for k = 3 to Code.worksheets(j).range("A65536").end(xlup).row
　　vntSearch = Code.Worksheets(j).Cells(k, 1).Value
　　strname = ""
　　On Error Resume Next
　　strname = Application.WorksheetFunction.VLookup(vntSearch, myrange, 6, False)
　　On Error GoTo 0
　　If strname <> "" Then
　　　Code.Worksheets(j).Cells(k, 2) = strname
　　End If
　next k

next j

アプローチ２：
セルを舐めるように１個ずつ巡回していくのは，簡単かもしれませんが一番遅いです。

dim j
for j = 2 to worksheets.count
　with colde.worksheets(j).range("B3:B" & .range("A65536").end(xlup).row)
　　.formula = "=VLOOKUP(A3,[転記元.xls]転記元!$A$4:$AX$5000,6,FALSE)"
　　on error resume next
　　.specialcells(xlcelltypeformulas, xlerrors).clearcontents
　　on error goto 0
　　.value = .value
　end with
next j

お礼

回答ありがとうございました。
Do Loopの脱出条件についてのご指摘ありがとうございます。早速、見直しを始めたいと思います。
また、少ない時間の中で2通りのやり方を教えて頂きありがとうございました。
今回の件で前述の方法を活用させて頂きたいと思います。

回答No.3

keithin

アプローチ２のマクロが編集中にミスっていたのに気がつきました。

【訂正】
アプローチ２：
セルを舐めるように１個ずつ巡回していくのは，簡単かもしれませんが一番遅いので，エクセルの機能を使って一括で処理してみます。

大概の場合，ワークシートに本来機能で関数を使わせた方が，高速です。
更に工夫するなら，転記元の現在のデータ範囲を先に取得して「より合理的な数式」を書かせると，モアベターです。これはどの方式でも使える方策です。

dim j
for j = 2 to worksheets.count
　with colde.worksheets(j)
　　with .range("B3:B" & .range("A65536").end(xlup).row)
　　　.formula = "=VLOOKUP(A3,[転記元.xls]転記元!$A$4:$AX$5000,6,FALSE)"
　　　on error resume next
　　　.specialcells(xlcelltypeformulas, xlerrors).clearcontents
　　　on error goto 0
　　　.value = .value
　　end with
　end with
next j

失礼しました。

お礼

わざわざありがとうございます。
提示して頂いた２パターンを試してみて、どちらも今後に生かせるように、またアレンジが
できるように読み解いて習得したいと思います。

回答No.1

kybo

Set myrange = Base.Worksheets("転記元").Range("A4:AX5000")
以降を以下の様にしてはどうでしょうか

Do
For i = 0 To Asc("わ") - Asc("あ") + 1
Code.Worksheets(Chr(Asc("あ") + i)).Range("B2:F200").ClearContents
vntSearch = Code.Worksheets(Chr(Asc("あ") + i)).Cells(i + 2, 1).Value
If vntSearch = "" Then Exit Do
On Error Resume Next
strname = ""
strname = Application.WorksheetFunction.VLookup(vntSearch, myrange, 6, False)
On Error GoTo 0
If strname <> "" Then
Code.Worksheets(Chr(Asc("あ") + i)).Cells(i + 2, 2) = strname
End If
Next i

Loop

お礼

回答ありがとうございました。
お二人に回答を頂き、色々な考え方・やり方があるのだなと感心しております。
頂いたコードはこの先、色々な場面で活用したいと思います。