简体   繁体   中英

Excel macro to copy data from one sheet to another based on specific matching conditions

I have two sheets, one of which contains data for all of the match codes (Master Sheet) and another that contains data for only some match some codes. These codes link to a data number (as well as other values) that I need to bring in from the "Master Sheet" to the other sheet. I used index match initially to bring over the values and data number, however I unfortunately did not notice that there are duplicate match codes that correspond to different values and data numbers, so I want to be able to go in and copy paste any data where the match codes link up, but the data number does not. For example:

 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 

As can be seen, Sheet 2 has Match codes 11111 and 11112 as does the Master Sheet, however I need to bring over all of the data that has corresponding match values but different data numbers. I however cannot copy over the entire master sheet because the Master sheet contains Match values not found in Sheet 2 such as 12343. Thus, sheet 2 would look like this after completed:

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  

Is there a way to make a macro to check the Match values in Sheet 2, and for every corresponding match value between the sheets, if that exact row is not already in Sheet 2, then copy over the entire row and paste it into sheet 2?

I have the following, but it isn't doing what I want it to:

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
  1. Build a dictionary of match codes and filter on those.
  2. Copy everything filtered over to the second worksheet.
  3. Remove duplicates based on match code and data number.
  4. [optional] Sort the new data.

BTW, your original code shows Sheet 2 , not 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

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM