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
