２つのものが一致時に転記するマクロ

Question

いつもお世話になります。

ここのサイトで
２つのブックでIDが一致したら
横にある文字を転記するというマクロがあるのですが
同じIDが続いても転記先のエクセルに全て転記したいと質問させて頂き
そのマクロを使わせて頂いたのですが

ＩＤと時間を一致したものを転記させなければいけなくなりました

Ａ列の時間とＢ列のＩＤを一致したときに
大元に転記させるのは、変数で2つの項目を設定して
確認させればいいのかと思っていましたが上手くいきません

更に、データ量が多いので
マクロを動かすたびに応答なしになるので
コードをfindから別なコードを変えたほうがよろしいのでしょうか？

下記にマクロのコードと構成と画像を記述させて頂きます
お手数ですがご教授して頂けないでしょうか？
恐縮ですがよろしくお願いいたします。

Sub 転記改造()
　　Dim w0 As Worksheet, w1 As Worksheet
　　Dim h As Range, Target As Range
    Dim i As Range, Target1 As Range
　　Dim FirstAddress As String

Set w0 = Workbooks("IDデータ.xls").Worksheets(1)
　　Set w1 = Workbooks("ID管理票.xls").Worksheets(1)

For Each h In w0.Range("A2:A" & w0.Range("A65536").End(xlUp).Row)
    For Each i In w0.Range("B2:B" & w0.Range("A65536").End(xlUp).Row)
　　　　If h.Offset(, 1).Value = "確認" Then
　　　　　　Set Target = w1.Range("D11:D60000").Find(what:=h.Value, LookIn:=xlValues, lookat:=xlWhole)
　　　　　　If Not Target Is Nothing Then
　　　　　　　　FirstAddress = Target.Address
　　　　　　　　Do
　　　　　　　　　　If Target.Offset(, -1).Value = "" Then
　　　　　　　　　　　　Target.Offset(, -1) = "確認"
　　　　　　　　　　　　Exit Do
　　　　　　　　　　Else
　　　　　　　　　　　　Set Target = w1.Range("D11:D60000").FindNext(Target)
　　　　　　　　　　End If
　　　　　　　　Loop While FirstAddress <> Target.Address
　　　　　　End If
　　　　End If
　　Next
　　next
End Sub

tom04 · Accepted Answer

こんばんは！
基本的に他人様がお考えのコードに手を付けるのは好みでないので、
新しくやってみました。

↓の画像のように左側が「IDデータ.xls」のSheet1で、右側が「ID管理票xls」のSheet1とします。

「ID管理票」ブックの標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
    Dim i As Long, lastRow1 As Long, lastRow2 As Long
    Dim c As Range, wS1 As Worksheet, wS2 As Worksheet
    Application.ScreenUpdating = False
    Set wS1 = Workbooks("IDデータ.xls").Worksheets(1)
        wS1.Activate
        lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
        wS1.Range("A:A").Insert
            Range(wS1.Cells(2, "A"), wS1.Cells(lastRow1, "A")).Formula = "=B2&""_""&C2"
        With ThisWorkbook.Worksheets(1)
            .Activate
            lastRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
                .Range("A:A").Insert
                .Range("A1") = "ダミー"
                Range(.Cells(2, "A"), .Cells(lastRow2, "A")).Formula = "=B2&""_""&C2"
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            Set wS2 = ThisWorkbook.Worksheets(Worksheets.Count)
            .Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS2.Range("A1"), unique:=True
            On Error Resume Next    '←念のため
            For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
                .Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, "A")
                Set c = wS1.Range("A:A").Find(what:=wS2.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
                    If Not c Is Nothing Then
                        Range(.Cells(2, "D"), .Cells(lastRow2, "D")).SpecialCells(xlCellTypeVisible) = "確認"
                    End If
            Next i
            .AutoFilterMode = False
            .Range("A:A").Delete
            wS1.Range("A:A").Delete
            Application.DisplayAlerts = False
                wS2.Delete
            Application.DisplayAlerts = True
            .Activate
        End With
        Application.ScreenUpdating = True
        MsgBox "処理完了"
End Sub

※　最初の質問がどのような結果がお望みだったのかが判らないので
的外れならごめんなさいね。m(_ _)m

tom04 · Answer

No.1です。
補足を読ませていただきました。

↓の画像のような配置でよろしいのでしょうか？

今回は「IDデータ.xls」の標準モジュールにしてみてください。
尚、コード内に若干のコメントを記載しています。

Sub Sample2()
    Dim i As Long, k As Long, lastRow1 As Long, lastRow2 As Long
    Dim wS1 As Worksheet, wS2 As Worksheet
    Application.ScreenUpdating = False
    Set wS2 = Workbooks("ID管理票.xls").Worksheets(1)
    lastRow2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row
        '▼「ID管理表票ook」のシート1、C～E列データ消去
        If lastRow2 > 1 Then
            Range(wS2.Cells(2, "C"), wS2.Cells(lastRow2, "C")).ClearContents
            Range(wS2.Cells(2, "E"), wS2.Cells(lastRow2, "E")).ClearContents
        End If
        '▼「ID管理票、シート1」のF列を作業用の列として使用
        Range(wS2.Cells(2, "F"), wS2.Cells(lastRow2, "F")).Formula = "=A2&""_""&B2"
    '▼「IDデータBook」のシート1～最終シートまでループ
    With ThisWorkbook
        For k = 1 To .Worksheets.Count
        Set wS1 = .Worksheets(k)
        lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
            '▼「IDデータBook」の各SheetのD列を作業用の列として使用
            If lastRow1 > 1 Then
                Range(wS1.Cells(2, "D"), wS1.Cells(lastRow1, "D")).Formula = "=A2&""_""&B2"
            '▼「ID管理票Book、シート1」の作業列（F列）でフィルタを掛ける
            '非表示になっている行のC列に「IDデータBook」の○番目シートのC列データを、E列にはシート名を！
            For i = 2 To lastRow1   '★
                wS2.Rows(1).AutoFilter field:=6, Criteria1:=wS1.Cells(i, "D")
                If wS2.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
                    Range(wS2.Cells(2, "C"), wS2.Cells(lastRow2, "C")). _
                        SpecialCells(xlCellTypeVisible) = wS1.Cells(i, "C")
                    Range(wS2.Cells(2, "E"), wS2.Cells(lastRow2, "E")). _
                        SpecialCells(xlCellTypeVisible) = wS1.Name
                End If
            Next i
                '▼「IDデータBook、各Sheet」の作業列を消去
                wS1.Range("D:D").ClearContents
            End If
        Next k
    End With
        '▼オートフィルタを解除、「ID管理票、シート1の作業列（F列）を消去
        wS2.AutoFilterMode = False
        wS2.Range("F:F").ClearContents
    Application.ScreenUpdating = True
End Sub

※　「ID管理票Bookのシート1」のF列と「IDデータBook」の各SheetのD列を作業用の列として使用していますので、
ID管理票Book、シート1はF列以降使用していない。
IDデータBook、各SheetはD列以降使用していない。
という前提です。

※　画像では各Sheetの1行目が項目行でデータは2行目以降にあるとしています。
尚、「IDデータBook」の各Sheetのデータが1行目からある場合は
コード内の「★」マークの行の
＞For i = 2 To lastRow1
を
＞For i = 1 To lastRow1
に変更してください。

こんな感じではどうでしょうか？m(_ _)m

２つのものが一致時に転記するマクロ

こんばんは！

この回答への補足

No.1です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング