1つのエクセル内で、シートからシートに、特定の項目を繰り返しコピペするマクロ[do while]

こんばんは。
エクセルVBAについて質問させていただきます。

＜※参照先シート＝以後シート①、書き込みシート＝以後シート②、条件シート＝以後シート③＞

やりたいことが複雑で、膨大なデータのコピペであります。
一旦VBAを組んでテストしたのですが、シート①からシート②にしっかりコピーされるデータもあれば、そうでないデータもあり、またシート①にないデータが、シート②に出たりで確実にコピーされず、上手くいきません。VBAの処理時間も数時間とかなり待たないと完了してくれません。

VBAの作りとして、繰り返し処理のDo while、条件のif、チェックのFLGをたくさん使って、最後代入しております。
すみませんが、上手くいける様アドバイスを頂けたらと思います。

今書いているプログラムは下記の通りです。

【処理内容】
ABCDEFの6項目を、シート①からシート②に繰り返しコピペします。
（条件としてB,Eの項目が一致すればコピペ）
A～Ｆ以外に、処理月というものがあり、シート①ではこの処理月は縦に出ておりますが、シート②の貼り付け先には、項目E,Fが月毎に横に表示されるようにします。（画像の例を参考ください）
シート③は条件（シート①）の不要なBの項目を削除する為の条件）をLIKE演算子を使って見に行きます。
シート①、シート③をみに行った際、FLGを入れております。

【VBA】
Sub test4()

Dim CNT1 As Long 'シート② 横の書き出し
Dim CNT2 As Long 'シート② 縦の書き出し
Dim LOOP1 As Long 'シート① 縦のループ
Dim LOOP2 As Long 'シート② 縦　確認のループ
Dim LOOP3 As Long 'シート③　縦のループ
Dim FLG1 As Long 'フラグ1
Dim FLG2 As Long 'フラグ2

CNT1 = 8 '横
CNT2 = 6 '縦

'シート①にデータがある間は処理を繰り返す
LOOP1 = 2
Do While Sheets("シート①").Cells(LOOP1, 1) <> ""

LOOP2 = 6
FLG1 = 0
'シート②にデータがある間は繰り返し実行
Do While Sheets("シート②").Cells(LOOP2, 1) <> ""
'シート①のと、シート②の項目Bが同じなら
If Sheets("シート①").Cells(LOOP1, 2) = Sheets("シート②").Cells(LOOP2, 2) Then
'シート①の項目Eと、シート②の項目Eが同じなら
If Sheets("シート①").Cells(LOOP1, 3) = Sheets("シート②").Cells(LOOP2, 4) Then
'チェック
FLG1 = 1
CNT2 = LOOP2
LOOP2 = 99999
End If
End If
LOOP2 = LOOP2 + 1
Loop

'【条件】条件シートを確認≫
LOOP3 = 2
FLG2 = 0
Do While Sheets("シート③").Cells(LOOP3, 2) <> ""
条件 = Sheets("シート③").Cells(LOOP3, 2)
If Sheets("シート①").Cells(LOOP1, 2) Like 条件 Then
FLG2 = 1
End If
LOOP3 = LOOP3 + 1
Loop

If FLG1 <> 1 Then
CNT2 = 6
Do While Sheets("シート②").Cells(CNT2, 1) <> ""
CNT2 = CNT2 + 1
Loop
End If

If FLG2 <> 1 Then
'値の代入
'項目A
Sheets("シート②").Cells(CNT2, 1) = Sheets("シート①").Cells(LOOP1, 5)
'項目B
Sheets("シート②").Cells(CNT2, 2) = Sheets("シート①").Cells(LOOP1, 2)
'項目C
Sheets("シート②").Cells(CNT2, 3) = Sheets("シート①").Cells(LOOP1, 4)
'項目D
Sheets("シート②").Cells(CNT2, 4) = Sheets("シート①").Cells(LOOP1, 3)
'項目E
Sheets("シート②").Cells(CNT2, CNT1) = Sheets("シート①").Cells(LOOP1, 17)
'項目F
Sheets("シート②").Cells(CNT2, CNT1 + 1) = Sheets("シート①").Cells(LOOP1, 19)
End If
LOOP1 = LOOP1 + 1
Loop
End Sub

以上よろしくお願い致します。

質問者からの補足コメント

• すみません、処理月の繰り返し処理は、問題ありませんでしたので、一旦このVBAには記載しておりません。

    補足日時：2020/05/24 20:44

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/05/24 23:30

こんばんは、結果に問題があるようですが、

取り敢えず、コードを整理した方が良いように思います。
アドバイスを行うのも奥がましいのですが、参考程度に

ここのループで言うと
'【条件】条件シートを確認≫
LOOP3 = 2
FLG2 = 0
Do While Sheets("シート③").Cells(LOOP3, 2) <> ""
条件 = Sheets("シート③").Cells(LOOP3, 2)
If Sheets("シート①").Cells(LOOP1, 2) Like 条件 Then
FLG2 = 1
End If
LOOP3 = LOOP3 + 1
Loop

これは、条件If Sheets("シート①").Cells(LOOP1, 2) Like 条件 Thenによって
FLG2 = 1を設定する事が目的かと思います。
下のIf FLG2 <> 1 Thenで分岐条件に設定されていますね、1ではTrueにならないようになっています。
つまり、1は、一度もIf Sheets("シート①").Cells(LOOP1, 2) Like 条件 ThenでTrueにならないなら時となりますね。
では、一度Trueになれば条件に当てはまる事になりますのでこのループは
Do While Sheets("シート③").Cells(LOOP3, 2) <> ""
条件 = Sheets("シート③").Cells(LOOP3, 2)
If Sheets("シート①").Cells(LOOP1, 2) Like 条件 Then
FLG2 = 1
Exit Do '1になったのでここでループを抜ける（処理を早く進める）
End If
LOOP3 = LOOP3 + 1
Loop

で良いと思います。データによりますが処理速度に差が出ます。
さらにループを回さなくとも一例としてべたにコードを書き写すと
　　If Not Sheets("シート③").Range("B2:B" & Sheets("シート③").Cells(Rows.Count, "B").End(xlUp).Row). _
　　　Find(what:=Sheets("シート①").Cells(LOOP1, "B"), LookAt:=xlPart) Is Nothing Then
　　　　 FLG2 = 1
　　　End If
こんな方法で同じ結果が得られると思います。
変数を使用したり.Resizeを使用したりしてわかり易くしてください。

　　　　Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
　　　　Dim Rng3 As Range
　　　　Set wS1 = Sheets("シート①")
　　　　Set wS2 = Sheets("シート②")
　　　　Set wS3 = Sheets("シート③")
　　　　Set Rng3 = wS3.Range("B2").Resize(wS3.Cells(Rows.Count, "B").End(xlUp).Row)

　　　　If Not Rng3.Find(what:=wS1.Cells(LOOP1, "B"), LookAt:=xlPart) Is Nothing Then
　　　　　　FLG2 = 1
　　　　End If


CNT2 = 6
Do While Sheets("シート②").Cells(CNT2, 1) <> ""
CNT2 = CNT2 + 1
Loop

これに関しては、Sheets("シート②")のA列の空白までの上の行番号をCNT2に入れたいと言う事でしょか？
であれば、
wS2.Cells(6, 1).End(xlDown).Row　になります。

同様の場所が見受けられますが、ACで字を読むのが辛くなったので、この辺で。。

この回答へのお礼

早速の回答ありがとうございます。
一度試してみます。
親切に教えていただき、感謝しております。

お礼日時：2020/05/25 16:56