Excel宏可根据特定的匹配条件将数据从一张纸复制到另一张纸

Question

我有两张纸，其中一张包含所有匹配代码（主纸）的数据，另一张仅包含一些匹配某些代码的数据。 这些代码链接到我需要从“主表”输入到另一个表的数据号（以及其他值）。 我最初使用索引匹配来获取值和数据编号，但是不幸的是我没有注意到有重复的匹配代码对应于不同的值和数据编号，因此我希望能够将所有数据复制粘贴到匹配代码链接起来，但是数据编号没有链接。 例如：

 Master Sheet

Match Code  Value 1   Value 2   Rate   data number
11111       1500      1200     2700      656565 
11111       1800      1800     3600      688888 
11112       1500      1100     2600      818987 
11112       1500      150      1650      986773 
12343       200       800      1000      785942

Sheet 2

Match Code  Value 1   Value 2   Rate   data number
11111       1500      1200     2700      656565  
11112       1500      150      1650      986773 

可以看出，工作表2和主工作表一样具有匹配代码11111和11112，但是我需要将所有具有对应匹配值但数据编号不同的数据都带过来。 但是，我无法复制整个母版表，因为母版表包含在工作表2中找不到的匹配值，例如12343。因此，完成后，工作表2看起来像这样：

Sheet 2

Match Code  Value 1   Value 2   Rate   data number
11111       1500      1200     2700      656565 
11111       1800      1800     3600      688888 
11112       1500      1100     2600      818987 
11112       1500      150      1650      986773  

有没有一种方法可以使宏检查工作表2中的匹配值，对于工作表之间的每个对应匹配值，如果工作表2中还没有该确切的行，则复制整行并将其粘贴到工作表2中？

我有以下内容，但它没有执行我想要的操作：

Sub pasteLoop()

'Iterator Worksheet 1, is the counter for the ws1 column
Dim iWS1 As Integer
'Iterator Worksheet 2, is the counter for the ws2 column
Dim iWS2 As Integer
'Switch New Row, is the switch if the next value need a new row
Dim sNR As Integer
'Maximal Row Count, need to be extend when new rows are added
Dim MaxRows As Integer
'valueHolder, is the holder for the orginal value, the orginal value might be replaced on the sheet
Dim valueHolder As Long

'Worksheet1
Dim ws1 As Worksheet
'Worlsheet2
Dim ws2 As Worksheet

Set ws1 = ActiveWorkbook.Worksheets("Sheet 2")
Set ws2 = ActiveWorkbook.Worksheets("Master Sheet")

'Set iWS1 to the first row
iWS1 = 1
'Get MaxRows
MaxRows = ws1.Cells(Rows.Count, 1).End(xlUp).Row

'Loop through the Rows on WS1 setting switch to 0 and store the value from the ws1 row in the holder
While iWS1 <= MaxRows
sNR = 0
valueHolder = ws1.Cells(iWS1, 1).Value

'Loop through the Rows on WS2, searching for a value that match with the value from ws1
For iWS2 = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
    'When it matches, then look if there was already a match with the value, if not replace it on the ws1 and increase the sNr to 1
    If valueHolder = ws2.Cells(iWS2, 1).Value Then
        If (sNR < 1) Then
            ws1.Cells(iWS1, 1).Value = ws2.Cells(iWS2, 2).Value
            sNR = sNR + 1
        'When the sNR is already > 0, increase the Iterator for the ws1 that he will point on the new line
        'increase the maxrows because we got one more soon, finally insert the new row and store the value from ws2 in it
        Else
            iWS1 = iWS1 + 1
            MaxRows = MaxRows + 1
            Range(ws1.Cells(iWS1, 1), ws1.Cells(iWS1, 1)).EntireRow.Insert
            ws1.Cells(iWS1, 1).Value = ws2.Cells(iWS2, 2)
        End If
    End If
Next iWS2
iWS1 = iWS1 + 1
Wend


End Sub

Answer 1

1. 构建一个匹配代码字典并对其进行过滤。
2. 将所有过滤后的内容复制到第二个工作表。
3. 根据匹配代码和数据编号删除重复项。
4. [可选]对新数据进行排序。

顺便说一句，您的原始代码显示Sheet 2 ，而不是Sheet2 。

Option Explicit

Sub same_old_same_old()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim d As Long, dMNUMs As Object

    Set ws1 = ActiveWorkbook.Worksheets("Master Sheet")
    Set ws2 = ActiveWorkbook.Worksheets("Sheet 2")
    Set dMNUMs = CreateObject("Scripting.Dictionary")
    dMNUMs.CompareMode = vbBinaryCompare

    '1. Build a dictionary of match codes and filter on those.
    With ws2
        For d = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            dMNUMs.Item(CStr(.Cells(d, "A").Value2)) = .Cells(d, "E").Value2
        Next d
    End With

    '2. Copy everything filtered over to the second worksheet.
    With ws1
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Cells(1, 1).CurrentRegion
            .AutoFilter Field:=1, Criteria1:=dMNUMs.keys, Operator:=xlFilterValues
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                If CBool(Application.Subtotal(103, .Cells)) Then
                    .Cells.Copy _
                      Destination:=ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                End If
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With

    '3. Remove duplicates based on match code and data number.
    '4. [optional] Sort the new data
    With ws2
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Cells(1, 1).CurrentRegion
            .RemoveDuplicates Columns:=Array(1, 5), Header:=xlYes
            .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Key2:=.Columns(5), Order2:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlYes
            End With
    End With

    dMNUMs.RemoveAll: Set dMNUMs = Nothing

End Sub