[[20221112163124]]　『マクロである条件が一致したら転記する方法』（桜）　ページの最後に飛ぶ

『マクロである条件が一致したら転記する方法』（桜）

転記元の検索キーと、転記先の検索キーを見比べて、一致したら、
転記元のB, C, D列の情報を、転記先のH, I, J列に転記したいです。
一応考えて動いたのですが、ちょっと分からない部分があり教えて下さい。

＜転記元＞

   A        B     C     D
 1 検索キー			
 2 a	    あ	  け	ち
 3 c	    い	  こ	
 4 b	    う	  	つ
 5 d	    え	  し	て
 6 dd	    お	  す	と
 7 cc	    か	  せ	
 8 aa	    き	  そ	な
 9 e	    く	  た	に

＜転記先＞　
G列の検索キーは予め入っています。マクロを稼働すると、H-J列に結果を出力させたい。

   G        H     I     J
 1 検索キー			
 2 c	    い	  こ	
 3 b	    う	  	つ
 4 e	    く	  た	に
 5 cc	    か	  せ

考えたコードは下記です。
Sub test()

Dim c As Range, myR As Variant
Dim LastRow As Long
LastRow = Cells(Rows.Count, "G").End(xlUp).Row

For Each c In Range("G2:G" & LastRow)

    If c.Value <> "" Then
        myR = Application.Match(c.Value, Columns("A:A"), 0)
        If Not IsError(myR) Then
            c.Offset(, 1).Value = Cells(myR, "B:B").Value
            c.Offset(, 2).Value = Cells(myR, "C:C").Value
            c.Offset(, 3).Value = Cells(myR, "D:D").Value
        End If
    End If
Next
End Sub

ご教授頂きたいのは、実際のデータは縦に横に長いです。
事例は転記列は3列だけですが、実際は20列とかあり。
行も1,000行程度あり。
自分の考えたコードでは、一列ずつ転記しています。
例：　c.Offset(, 1).Value = Cells(myR, "B:B").Value

これを一括で、事例の場合は、BからD列の情報を、HからJ列に貼り付けるのようにしたいのですが、分かりません。
OffsetとResizeとか組み合わせると可能でしょうか？

＜使用 Excel：Office365、使用 OS：Windows10 ＞

オートフィルタで検索キーを抽出してコピペする案です。
フィルター範囲外に一度非難するために下の行を使用してますが、別シートのほうがいいかもしれません。

 Sub test()
     Dim LastR As Long, rng
     LastR = Cells(Rows.Count, "G").End(xlUp).Row
     rng = WorksheetFunction.Transpose(Range("G2").Resize(LastR - 1))
     With Range("A1")
         .AutoFilter 1, rng, xlFilterValues
         .CurrentRegion.Copy Range("A15")
         .AutoFilter
     End With
     Application.CutCopyMode = False
     Range("A15").CurrentRegion.Cut Range("G1")
 End Sub
（フォーキー） 2022/11/12(土) 17:36:14

すみません、A列にない検索キーがG列にあった場合、貼り付け後の結果がおかしくなりますね。下を追加してください。

 Range("G1").CurrentRegion = ""

あと、A列の抽出結果をそのままG1セルにコピペしているので、G列の検索キーの並びがA列の並びに上書きされます。

（フォーキー） 2022/11/12(土) 17:50:24

フォーキー様
ありがとうございます。
オートフィルタだと早そうですね！
ただ、並びは変えたくないのですよね。
今後の考え方の参考に、とても勉強になりました。
ありがとうございます。
（桜） 2022/11/12(土) 18:04:58

貼り付け後に最初のG列の順番にソートする処理を追加してみました。
不格好なので参考程度にでも。
G列にA列にはない検索キーがあって、検索キーを残したまま行を空白にしたい場合は、ソート案は破棄してください。

 Sub test2()
     Dim LastR As Long, i As Long, buf As String, rng
     LastR = Cells(Rows.Count, "G").End(xlUp).Row
     rng = WorksheetFunction.Transpose(Range("G2").Resize(LastR - 1))
     '検索キーを抽出
     With Range("A1")
         .AutoFilter 1, rng, xlFilterValues
         .CurrentRegion.Copy Range("A15")
         .AutoFilter
     End With
     '並べ替えのための文字列作成
     For i = 1 To UBound(rng)
        buf = buf & "," & rng(i)
     Next
     '貼り付け
     Range("G1").CurrentRegion = ""
     Application.CutCopyMode = False
     Range("A15").CurrentRegion.Cut Range("G1")
     '最初のG列の順番にソート
     With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("G2"), CustomOrder:=Mid(buf, 2)
        .SetRange Range("G1").CurrentRegion
        .Header = xlYes
        .Apply
     End With
 End Sub
（フォーキー） 2022/11/12(土) 18:50:24

フォーキー様
ありがとうございます。
順番を格納して、このようにSort機能で戻す事も出来るのですね。
ありがとうございます。
参考にさせて頂きます。
（桜） 2022/11/12(土) 20:23:54

 1行ずつの処理になってしまいますが、
 連想配列を用いてみました。
 検索キーが重複しないことが前提です。
 A～U列にデータがあり、検索キーがW列にあるものとします。

    Sub macro()
        Dim dic As Object
        Dim r As Range
        Set dic = CreateObject("Scripting.Dictionary")
        For Each r In Range("A2", Cells(Rows.Count, "A").End(xlUp))
            dic(r.Value) = r.Offset(, 1).Resize(, 20).Value
        Next
        For Each r In Range("W2", Cells(Rows.Count, "W").End(xlUp))
            r.Offset(, 1).Resize(, 20) = dic(r.Value)
        Next
    End Sub
（dic） 2022/11/12(土) 22:23:58

dic様
ありがとうございます。
このように一括で出来るのですね。Dictionary勉強してみます。
元ねた、転記先、それぞれ色々なパターンで重複ありで実験してみましたが、理解しました。
使い方に注意してみます。大変ありがとうございました！

（桜） 2022/11/13(日) 11:33:17

もう見てないと思いますが。
コピーは非表示セルは含みませんが、貼り付け先セルは非表示セルも含まれるんですね。
フィルター実行中に上から貼り付けても問題なかったです。

 Sub test3()
     Dim LastR As Long, i As Long, buf As String, rng
     LastR = Cells(Rows.Count, "G").End(xlUp).Row
     rng = WorksheetFunction.Transpose(Range("G2").Resize(LastR - 1))
     '検索キーを抽出してG1セルに貼り付け
     With Range("A1")
         Range("G1").CurrentRegion = ""
         .AutoFilter 1, rng, xlFilterValues
         .CurrentRegion.Copy Range("G1")
         .AutoFilter
     End With
     '並べ替えのための文字列作成
     For i = 1 To UBound(rng)
        buf = buf & "," & rng(i)
     Next
     '最初のG列の順番にソート
     With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("G2"), CustomOrder:=Mid(buf, 2)
        .SetRange Range("G1").CurrentRegion
        .Header = xlYes
        .Apply
     End With
 End Sub
（フォーキー） 2022/11/14(月) 19:08:48

コメント返信：

[ 一覧(最新更新順) ]

[[20221112163124]] 『マクロである条件が一致したら転記する方法』（桜） ページの最後に飛ぶ

[[20221112163124]]　『マクロである条件が一致したら転記する方法』（桜）　ページの最後に飛ぶ