1150655874

2022/5/27 8:40

33回答

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

VBAデータ抽出でご教授お願いします。 やりたいこと sheet1のデータの重複する値を削除して sheet2のデータを取り込みsheet3に転記したいです。 ※ sheet1のコードのみで重複削除して【サブ・サイズ・賞味はどれもいい】 sheet2のデータを取り込み【C～FまでをサブコードC列とサイズD列の間につけたい】sheet3に転記 VBAは書いてあるのは読み取れる程度の初心者です。 よろしくお願いいたします。

画像

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

ベストアンサー

0
どうしても勝ってみたい！！

2022/5/27 11:49

文字数の関係で再回答： シート１は使ってません。 理由については終盤に疑問点として挙げてあります。 Sub try() Dim myDic As Object Dim r As Range Dim key As Variant Set myDic = CreateObject("Scripting.Dictionary") With Worksheets("Sheet2") For Each r In .Range("A1", .Cells(Rows.Count, "A").End(xlUp)) If Not myDic.Exists(r.Value) Then Set myDic(r.Value) = r.Range("C1:F1") Next End With With Worksheets("Sheet3") .Columns("D:F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove For Each r In .Range("A1", .Cells(Rows.Count, "A").End(xlUp)) If myDic.Exists(r.Value) Then myDic(r.Value).Copy r.Range("D1") Next End With Set myDic = Nothing End Sub 以前の回答： ＞【C～FまでをサブコードC列とサイズD列の間につけたい】 ここの意味が不明。 シート３には画像のＤ～Ｇ列は本来無いので挿入し割り込ませたいと言う事？ 書いてあるのが読み取れるって私よりは上級かも。 私は人が作ったコードを理解するのは難しいです。 回答者によっては参考書等とは違う自己流な手段を用いる方もいますので。 ところで不思議なのは『コード』についてですが、何故シート２ではなくシート１の値を使用するのでしょう？ 仮にシート１に存在しシート２に存在しない『コード』があれば、シート２の他の値は得られませんよね。 それでもシート１の『コード』重複削除は必要なのですか？ 画像で言えば『9004 ガム』『9005 ガム』とかになります。 それでもシート１の『コード』重複削除作業を含んだ値取得は必要なのですか？

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
kky********

2022/5/27 10:51

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人がナイス！しています