お世話になります。VBAについてお力をお借りできたらと思います。 下記のコードに条件を足したいのですが、うまくいかないため質問いたしました。 まず、やりたい事（現状）：
お世話になります。VBAについてお力をお借りできたらと思います。 下記のコードに条件を足したいのですが、うまくいかないため質問いたしました。 まず、やりたい事（現状）： ① Sheet2の特定データを抽出し、Sheet１へ必要な項目のみ転記 Sheet2 5行目以降：C,D,G,H,N → Sheet1 5行目以降：（A,B,C,D,E）転記 ② Sheet1へ転記するは、Sheet 2 の区分け番号①（D列）の末尾にSheet3で指定しているものを除く全てを抽出 ※画像にSheet 3はありませんが、Sheet 3 では、/000 /111 /222など記載してあります 追加したいこと： 上記②にSheet 2の区分け番号②（E列）が空白の場合も、Sheet 1に抽出をしない様にしたいです。 お忙しいところ恐縮ですが、何卒よろしくお願いいたします。 Sub Extract() Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet Dim tbl, ctbl As Variant Dim i, r1, r3 As Long Dim j As Integer Dim matchflag As Boolean Application.ScreenUpdating = False Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") Set ws3 = Worksheets("Sheet3") With ws3 tbl = .Range("A1:A28") End With ctbl = Array(3, 4, 7, 8, 14) r3 = 4 With ws2 For r1 = 5 To .Cells(Rows.Count, 4).End(xlUp).Row matchflag = False For i = 1 To UBound(tbl) If .Cells(r1, 4).Value Like "*" & tbl(i, 1) Then matchflag = True Exit For End If Next i If matchflag = False Then r3 = r3 + 1 For j = 0 To 4 Ws1.Cells(r3, j + 1).Value = .Cells(r1, ctbl(j)).Value Next j End If Next r1 End With Application.ScreenUpdating = True End Sub
Visual Basic | Excel・114閲覧・50
ベストアンサー
以下のようなものでしょうか？ Sub Extract() Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet Dim tbl, ctbl As Variant Dim i, r1, r3 As Long Dim j As Integer Dim matchflag As Boolean Application.ScreenUpdating = False Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") Set ws3 = Worksheets("Sheet3") With ws3 tbl = .Range("A1:A28") End With ctbl = Array(3, 4, 7, 8, 14) r3 = 4 With ws2 For r1 = 5 To .Cells(Rows.Count, 4).End(xlUp).Row matchflag = False If ws2.Cells(r1, 5).Value = "" Then matchflag = True Else For i = 1 To UBound(tbl) If ws2.Cells(r1, 4).Value Like "*" & tbl(i, 1) Then matchflag = True Exit For End If Next i End If If matchflag = False Then r3 = r3 + 1 For j = 0 To 4 ws1.Cells(r3, j + 1).Value = .Cells(r1, ctbl(j)).Value Next j End If Next r1 End With Application.ScreenUpdating = True End Sub 以下は、コードを見やすいかなと思って変更してみたものです。 Sub Extract() Dim ws1 As Worksheet, ws2 As Worksheet Dim matchflag As Boolean, tbl As Variant Dim i, r1, r3 As Long Application.ScreenUpdating = False Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") tbl = Worksheets("Sheet3").Range("A1:A28") r3 = 4 For r1 = 5 To ws2.Cells(ws2.Rows.Count, "D").End(xlUp).Row matchflag = False If ws2.Cells(r1, "E").Value = "" Then matchflag = True Else For i = 1 To UBound(tbl) If ws2.Cells(r1, "D").Value Like "*" & tbl(i, 1) Then matchflag = True Exit For End If Next i End If If matchflag = False Then r3 = r3 + 1 ws1.Cells(r3, "A").Value = ws2.Cells(r1, "C").Value ws1.Cells(r3, "B").Value = ws2.Cells(r1, "D").Value ws1.Cells(r3, "C").Value = ws2.Cells(r1, "G").Value ws1.Cells(r3, "D").Value = ws2.Cells(r1, "H").Value ws1.Cells(r3, "E").Value = ws2.Cells(r1, "N").Value End If Next r1 Application.ScreenUpdating = True Set ws1 = Nothing Set ws2 = Nothing End Sub
質問者からのお礼コメント
ご丁寧にありがとうございます！やりたい事が出来ました！詳しく書いていただいたので、BAとさせて頂きます。 また、何かあれば、お力をお借りできたらとおもいます。 本当にありがとうございます！
お礼日時：7/6 14:39
