Excel VBA 配列による複数セルへの入力

質問

VBA初心者です．よろしくお願いいたします．
用語の読みを自動で振るシートを作成しているのですが，Do Loop部分が一行ずつの入力となっていて，時間がかかっています．
これを配列等の方法を用いて高速化したいと思って，試行錯誤したのですが，うまくいきません．
何卒お教えくださいますようお願いいたします．

用語の読みを生成する手順ですが，
１．シート1に用語をペーストする
２．ペーストされた用語をシート２にある用語のDB（用語と読みが入力されています．重複レコードなし）にコピー
３．コピーされたシート２をピボットにして個数が２以上あった場合，その用語と読みを返します．
４．Do Loopで最初にヒットした用語に戻るまでループ
となっています．

３までの手順に修正の必要はないのですが，４の手順でかなり時間をロスしております．
ここを配列等の方法で一度に書き込むことができればと思っています．

Sub test()
i = 8
L_Row04 = 180188
Dim S1 As Worksheet '読みを振る用語をペーストするシート
Dim S2 As Worksheet '読み用の用語のDB
Dim S3 As Worksheet 'ピボット
Dim L_Row01 As Long 'S1にペーストされた用語の最下行
Dim L_Row02 As Long 'S1の用語をs2にペーストしたときの最下行
Dim L_Row03 As Long 'ピボットの用語の最下行

Dim Rng01 As Range 'S1にペーストされた用語の範囲
Dim Rng02 As Range 'S2にペーストされた用語の範囲
Dim Rng03 As Range 'ピボットの範囲
Dim Str01 As Variant 'ピボットで2以上あったときの用語
Dim Str02 As Variant 'ピボットで2以上あったときの読み
Dim firstcell As Range
Dim Foundcell01 As Range
Set S1 = Worksheets(1)
Set S2 = Worksheets(2)
Set S3 = Worksheets(3)

S1.Activate
L_Row01 = S1.Cells(Rows.Count, 2).End(xlUp).Row
L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row

Set Rng01 = S1.Range(Cells(i, 2), Cells(L_Row01, 2))

Rng01.Copy Destination:=S2.Cells(L_Row02 + 1, 2 + 1)

S3.PivotTables("ピボットテーブル2").RefreshTable

S2.Activate
L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row
Set Rng02 = S2.Range(Cells(L_Row04, 3), Cells(L_Row02, 3))
Rng02.Delete

S3.Activate
L_Row03 = S3.Cells(Rows.Count, 2).End(xlUp).Row
Set Rng03 = S3.Range(Cells(4, 2), Cells(L_Row03, 2))

For Each a In Rng03
If a >= 2 And a.Offset(0, -1).Value <> "(空白)" And a.Offset(1, -1).Value <> "(空白)" Then
Str01 = a.Offset(0, -1)
Str02 = a.Offset(1, -1)
S1.Activate
Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole)
Do
Selection.Offset(0, 1).Value = Str02
Selection.Offset(0, 2).Value = "●"
Loop Until ActiveCell.Address = firstcell.Address
End If
End If
Next
End Sub

回答No.2

end-u · ベストアンサー

>シート2には，用語と読みが一緒になったDBがあります（用語と読みは1対1です）．
その場合、Do..Loopは必要ないです。
：
>Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole)
>If Not Foundcell01 Is Nothing Then
>　　Set firstcell = Foundcell01
>　　Foundcell01.Select
>　　Do
>　　　　Selection.Offset(0, 1).Value = Str02
>　　　　Selection.Offset(0, 2).Value = "●"
>　　Loop Until ActiveCell.Address = firstcell.Address
>End If
：
以下のように書きます。

Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole)
If Not Foundcell01 Is Nothing Then
　　Foundcell01.Offset(0, 1).Value = Str02
　　Foundcell01.Offset(0, 2).Value = "●"
End If

ただし、用語の個数をピボットでチェックして、
登録済み用語のみをFindメソッドで検索してシート1に『当て』にいく..
ような処理は効率悪いです。
>..速度の面でピボットのほうが断然早いため，改修したという経緯がございます．
前回提示したSub sample()を実行してみたらどうなりますか？
比較してみてください。
もっと速度を上げたい場合はdictionaryオブジェクトを使う事になります。
http://okwave.jp/qa/q6327928.html?order=asc

お礼

ご教示ありがとうございます．
dictionaryオブジェクトを初めて知りました．
すごい方法があるのですね．
まさに現在開発中のものにぴったりです．
ピボットがもっとも高速だと思い込んでいた知識の浅さに恥じ入るばかりです．
先般お示しいただきましてvlookupと一緒にじっくり取り組んで，現在のコードに実装したいと存じます．
この度はお世話になりました．

回答No.1

end-u

:
>Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole)
>Do
>Selection.Offset(0, 1).Value = Str02
>Selection.Offset(0, 2).Value = "●"
>Loop Until ActiveCell.Address = firstcell.Address
>End If
>End If
:
ここはまともに動きませんよね。
ですのでコードを見てもやりたい事がわかりません。
「用語」と「読み」は１対１ではなくて１対複数なのですか？
だからDo Loopを使っているのだとしても、書き込み位置がどう変化しているのか不明なので
具体的なアドバイスのしようがないです。

>３までの手順に修正の必要はないのですが，..
ピボットテーブルを使う意図がわかりません。
もし「用語」と「読み」が１対１ならVlookup関数を使えばすむ話のようですが..
Sub sample()
　　Dim r1 As Range
　　Dim r2 As Range
　　Dim r　As Range

　　With Worksheets(1)
　　　　Set r1 = .Range("B8", .Cells(.Rows.Count, 2).End(xlUp)).Offset(0, 1)
　　End With
　　With Worksheets(2)
　　　　Set r2 = .Range(.Cells(.Rows.Count, 3).End(xlUp), "D1")
　　End With

　　r1.Value = Application.VLookup(r1.Offset(0, -1), r2, 2, 0)
　　r1.Offset(0, 1).Value = "●"
　　On Error Resume Next
　　Set r = r1.SpecialCells(xlCellTypeConstants, xlErrors)
　　On Error GoTo 0
　　If Not r Is Nothing Then
　　　　r.ClearContents
　　　　r.Offset(0, 1).ClearContents
　　End If
End Sub

お礼

ご回答ありがとうございます．

また，こちらの記述や説明に不足があり，失礼いたしました．

Do の上の以下の3行分の記述が抜けておりました．
申し訳ありません．

If Not Foundcell01 Is Nothing Then
Set firstcell = Foundcell01
Foundcell01.Select

こちらの行いたいことを再度ご説明させていただきます．

シート1には，読みを振りたい用語をB8を起始として数千から数万ペーストします．

【例】
東京
北海道
青森
・
・

シート2には，用語と読みが一緒になったDBがあります（用語と読みは1対1です）．

用語　読み
東京　とうきょう
神奈川　かながわ
千葉　　ちば
埼玉　　さいたま

シート1にペーストされた用語は，シート2の最下行にペーストされます

用語　読み
東京　とうきょう
神奈川　かながわ
千葉　　ちば
埼玉　　さいたま
東京
北海道
青森

このデータをシート3のピボットで個数を調べ，個数が2以上だった場合に読みと用語を返します．
返された用語をシート1で検索して，読みを転記しています（この転記がDo Loopでない方法で一括で行えないでしょうかというのが今回の質問になります）．

また，上の例ですと東京には読みが振られますが，北海道と青森には読みが振られません．
北海道と青森に関しては，Leftを使って用語を分解して上記手順のピボットでの完全一致を行い読みをふり，Leftで抽出した以外の部分（残り部分）にも同様の方法で読みを振ることを行います．

それでも読みが振られない場合は，正規表現を利用して，漢字とそれ以外に分割して，漢字部分をピボットに送り，完全一致で検索して読みを振ります．
それでも読みが振られないものに対しては，GetPhoneticで読みを生成しております．

ピボットを使う前はvlookupで記述していたのですが，速度の面でピボットのほうが断然早いため，改修したという経緯がございます．

なにとぞよろしくお願いいたします．