VBAデータ抽出でご教授お願いします。 やりたいこと sheet1のデータの重複する値を削除して sheet2のデータを取り込みsheet3に転記したいです。 ※

画像

Visual Basic87閲覧xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0

ThanksImg質問者からのお礼コメント

ありがとうございました。 コード解読してみます(^^)

お礼日時:5/27 14:27

その他の回答(2件)

1
ID非公開

2022/5/27 12:20

これでどうでしょうか。 Sub sample() Dim i As Long, j As Long, n As Long, r As Long, rr As Long Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet Dim s As String, v As String Dim ary() Application.ScreenUpdating = False Set sh1 = Worksheets("Sheet1") Set sh2 = Worksheets("Sheet2") Set sh3 = Worksheets("Sheet3") With sh1 r = .Cells(Rows.Count, 1).End(xlUp).Row ReDim ary(r, 9) For i = 2 To r v = .Cells(i, "B") For j = i + 1 To r + 1 If .Cells(j, "B") <> v Then ary(n, 0) = .Cells(i, 1) ary(n, 1) = .Cells(i, 2) s = .Cells(i, 2) ary(n, 2) = .Cells(i, 3) ary(n, 7) = .Cells(i, 4) ary(n, 8) = .Cells(i, 5) Call SHData(ary, n, s, sh2) n = n + 1 i = j - 1 Exit For End If Next j Next i End With With sh3 rr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Columns(3).NumberFormatLocal = "@" .Cells(rr, 1).Resize(UBound(ary, 1), 9) = ary End With Application.ScreenUpdating = True End Sub Sub SHData(ByRef ary As Variant, ByRef n As Long, _ ByVal s As String, ByVal sh2 As Worksheet) Dim i As Long, r As Long With sh2 r = .Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r If .Cells(i, 2) = s Then ary(n, 3) = .Cells(i, 3) ary(n, 4) = .Cells(i, 4) ary(n, 5) = .Cells(i, 5) ary(n, 6) = .Cells(i, 6) End If Next i End With End Sub

1人がナイス!しています

1

Sheet3は先に1行目に項目名だけ入力されているものとします。 Sub test() Dim dic As Object Dim sh As Worksheet Dim r As Long Dim dkey As Variant Dim rng As Range Dim i As Integer Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set sh = Worksheets("Sheet1") With sh For r = 2 To .Cells(Rows.Count, 2).End(xlUp).Row dkey = .Cells(r, 2).Value If dic.Exists(dkey) = False Then dic.Add dkey, r End If Next r End With With Worksheets("Sheet2") Set rng = .Range("B2:F" & .Cells(Rows.Count, 2).End(xlUp).Row) End With With Worksheets("Sheet3") r = 1 For Each dkey In dic.Keys r = r + 1 .Cells(r, 1).Resize(, 3).Value = sh.Cells(dic.Item(dkey), 1).Resize(, 3).Value .Cells(r, 8).Resize(, 2).Value = sh.Cells(dic.Item(dkey), 4).Resize(, 2).Value For i = 4 To 7 .Cells(r, i).Value = Application.VLookup(dkey, rng, i - 2, False) Next i Next dkey End With Set dic = Nothing Application.ScreenUpdating = True End Sub

1人がナイス!しています