Question

我有两张纸，其中一张包含所有匹配代码（主表）的数据，另一张包含仅某些匹配某些代码的数据。这些代码链接到我需要从＆＃34;主表单＆＃34;中引入的数据编号（以及其他值）。到另一张纸。我最初使用索引匹配来带来值和数据，但遗憾的是我没有注意到有重复的匹配代码对应不同的值和数据编号，所以我希望能够进入并复制粘贴任何数据匹配代码链接，但数据编号没有。例如：

 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

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

BTW，您的原始代码显示工作表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

Excel宏根据特定的匹配条件将数据从一个工作表复制到另一个工作表

1 个答案: