Question

我有两个excel工作簿：1-工作簿有19列8行，另一个工作簿有8个行名和19个列名，与workbook1相同，但它不包含任何数据。我需要通过完全匹配rownames来复制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

您的推荐有点混淆。

我已将您的代码重构为：

遍历wb2中的行，因为这是您要更新的表单
在wb1
如果找到，请将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

vba编码，用于查找从一个工作簿到另一个工作簿的数据匹配和复制范围

1 个答案: