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

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

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，但是我需要将所有具有相应匹配值但不同数据编号的数据带过来。 但是，我不能复制整个主表，因为主表包含12343等工作表2中找不到的匹配值。因此，工作表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 

有没有办法让一个macros来检查工作表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. build立一个匹配代码字典和filter。
2. 复制过滤到第二个工作表的所有内容。
3. 根据匹配码和数据编号删除重复项。
4. [可选]对新数据进行sorting。

顺便说一句，您的原始代码显示工作表2 ，而不是工作表2 。

 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