vba 编码以查找匹配项并将数据范围从一个工作簿复制到另一个工作簿

Question

我有两个 Excel 工作簿：1- 工作簿有 19 列和 8 行，另一个工作簿有 8 行名称和 19 列名称，与 workbook1 相同，但它不包含任何数据。我需要通过完全匹配行名来从 workbook1 复制数据范围。
例如：
工作簿1：

icn id     location
1   125      M
2   123      F
3   132      G
4   145      H
5   145      I

工作簿2：

icn  id  Location
1
3
5
4
2

我尝试过编码，但无法获取数据范围：

Sub UpdateW2()

Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, FR As Long

Application.ScreenUpdating = False

Set w1 = Workbooks("workbookA.xlsm").Worksheets("Sheet1")
Set w2 = Workbooks("workbookB.xlsm").Worksheets("Sheet1")


For Each c In w1.Range("A2", w1.Range("A" & Rows.Count).End(xlUp))
  FR = 0
  On Error Resume Next
  FR = Application.Match(c, w2.Columns("A"), 0)
  On Error GoTo 0
  If FR <> 0 Then w2.Range("C" & FR).Value = c.Offset(, 0)
Next c
Application.ScreenUpdating = True
End Sub

Answer 1

您的参考文献有点混乱。

我已将您的代码重构为：

1. 循环遍历wb2 中的行，因为这是您要更新的工作表
2. 在wb1 中查找每一行
3. 如果找到，将B 和C 列从wb1 复制到wb2

请注意，如果Application.Match 没有找到匹配项，它不会抛出运行时错误，它会返回错误值（另一方面，Application.WorksheetFunction.Match 会抛出运行时错误)

Sub UpdateW2()
    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range
    Dim FR As Variant '<-- use Variant to allow catching a Error value
    Dim ws1Range As Range, ws2Range As Range

    Application.ScreenUpdating = False

    Set w1 = Workbooks("workbookA.xlsm").Worksheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Worksheets("Sheet1")

    Set ws1Range = w1.Range("A2", w1.Range("A" & w1.Rows.Count).End(xlUp))
    Set ws2Range = w2.Range("A2", w2.Range("A" & w2.Rows.Count).End(xlUp))

    For Each c In ws2Range
        FR = Application.Match(c.Value, ws1Range, 0)
        If Not IsError(FR) Then
            ' Choose ONE of the next three blocks of code

            ' To copy formula and format
            'ws1Range.Cells(FR, 2).Resize(, 2).Copy Destination:=c.Cells(1, 2).Resize(, 2)

            ' to copy only values
            'c.Cells(1, 2).Resize(, 2) = ws1Range.Cells(FR, 2).Resize(, 2)

            ' To copy values and format
            c.Cells(1, 2).Resize(, 2) = ws1Range.Cells(FR, 2).Resize(, 2)
            ws1Range.Cells(FR, 2).Resize(, 2).Copy
            c.Cells(1, 2).Resize(, 2).PasteSpecial Paste:=xlPasteFormats
        End If
    Next c
    Application.ScreenUpdating = True
End Sub