VBA 宏循环遍历单元格、查找匹配项并复制相邻单元格

Question

我希望有一个宏，它在运行时会在两列中查找匹配项（DISPLAY 表上的 M 列和 REPORT_DOWNLOAD 表上的 A 列），然后在匹配时复制相邻的 3 个单元格在 REPORT_DOWNLOAD 表（单元格 B、C 和 D）上，并将它们分别粘贴到 DISPLAY 表的单元格 S、T 和 U 中。

每个单元格只有一个匹配项。我已经尝试处理一些以前的 vba 代码，这些代码正在寻找每个匹配的多个实例，但我认为我在这一点上让自己感到困惑:(

任何帮助将不胜感激。

Sub Display()

Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("DISPLAY")
Set ws2 = ThisWorkbook.Sheets("REPORT_DOWNLOAD")

Dim arr_1 As Variant, arr_2 As Variant, arr_result As Variant
arr_1 = ws1.Range("K2:K" & ws2.Range("D" & ws2.Rows.Count).End(xlUp).Row).Value2
arr_2 = ws2.Range("A2:L" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).Value2

ReDim arr_result(LBound(arr_2) To UBound(arr_2), 1 To 3)

Dim i As Long, j As Long

For i = LBound(arr_1, 1) To UBound(arr_1, 1)
    For j = LBound(arr_2, 1) To UBound(arr_2, 1)

        If arr_1(i, 1) = arr_2(j, 1) Then
  
            arr_result(i, 1) = arr_2(j, 6)
            arr_result(i, 2) = arr_2(j, 7)
            arr_result(i, 3) = arr_2(j, 8)
        End If

    Next j
Next i

ws1.Cells(2, 17).Resize(UBound(arr_result, 1), 3).Value2 = arr_result

End Sub

Answer 1

这通常是这样完成的：

Sub updateDisplayList()
Rem Just define work sheets:
Dim wsSource As Worksheet: Set wsSource = Worksheets("REPORT_DOWNLOAD")
Dim wsTarget As Worksheet: Set wsTarget = Worksheets("DISPLAY")
Rem
Dim rSearch As Range, rWhat As Range, rBase As Range, oCell As Range
Dim vVar As Variant
Rem Column A of source sheet:
    Set rSearch = Application.Intersect(wsSource.UsedRange, wsSource.Columns(1)).Offset(1, 0)
Rem 3 first cells in columns which will be copied
    Set rBase = wsSource.Range("B1:D1")
Rem Range with data to search: used part of column M
    Set rWhat = Application.Intersect(wsTarget.UsedRange, wsTarget.Range("M:M"))
    For Each oCell In rWhat
        If Not IsEmpty(oCell) Then
            vVar = Application.Match(oCell.Value, rSearch, 0)
            If Not IsError(vVar) Then
                rBase.Offset(vVar, 0).Copy Destination:=oCell.Offset(0, 6)
Rem If you want to clear target cells when value not found in source sheet:
            Else
                oCell.Offset(0, 6).Resize(1, 3).ClearContents
            End If
        End If
    Next oCell
End Sub

（不确定 M 列 - 在您的代码中您使用 K 列的值）