Question

我有6个excel工作簿：1-工作簿有19列和40行（主工作簿），其他5个工作簿具有与工作簿1相同的19列名，与工作簿1相同的8行名（工作簿1中的40行被分为5行因此，每个工作簿中有8行）我需要通过将行名与所有5个工作簿中的行名完全匹配来从workbook1复制数据范围。这五个工作簿均由其在主工作簿中存在的唯一ID表示，因此，通过匹配该主键，只需将数据范围复制并粘贴到该特定工作簿中即可。我的代码通过将行名从一个工作簿匹配到另一工作簿来帮助我复制数据，但是我不知道如何找到主键并将该特定范围转移到该特定工作簿中。所有5个工作簿都在同一文件夹中。例如：

Workbook1:

      Icn  Primarykey  Location  Q1    Q2
       1   125          M        25    30
       2   125          F        30    35
       3   125          G        40    45
       4   125          H        50    55
       5   125          I        60    56

       1   126          M        21    31
       2   126          F        32    37
       3   126          G        41    48
       4   126          H        53    59
       5   126          I        62    50

       1   127          M        28    39
       2   127          F        38    39
       3   127          G        48    49
       4   127          H        58    57
       5   127          I        68    57
Workbook2:
125
icn  id  Location Q1 Q2
1
3
5
4
2

Workbook3:
126
icn  id  Location Q1 Q2
1
3
5
4
2

Workbook4:
127
icn  id  Location Q1 Q2
1
3
5
4
2

我的代码：

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

查找关键字并复制数据范围

0 个答案: