Match, Copy, and Add Values between Sheets

Question

Looking to match values of column 1&2 of the same row on sheet2 to values of column 1&2 of the same row on sheet1. Then, copy entire row of sheet1 match onto next blank row of sheet3 + copy value of column 3+4 of same row sheet2 onto end of pasted row on sheet3.

IF Sheet2 Row First&Last (column1&2) Name match Sheet1 Row First&Last (column1&2)
THEN
Copy Sheet1 Row, paste to Sheet3 @ next blank Row. Copy Sheet2 Row column 3+4 @ end of previously pasted Row on Sheet3

Here is what I have so far, this doesn’t do anything right now but I have pieced it together from a few working macros to try and accomplish what I’m after. I haven’t been able to find examples of “Copy Sheet2 Row column 3+4 @ end of previously pasted Row on Sheet3” so I just have a description on the line where I think the code should go.

{Sub Match_Copy_AddValues()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False

Set s1 = ActiveSheet 'List with dump data'
Set s2 = Sheets("Sheet 2") 'List of names to match, and additional information to be added'
Set s3 = Sheets("Sheet 3") 'Worksheet to copy rows of matched names'
Dim r As Long 'Current Row being matched?'

On Error GoTo fìn
Set ws2 = Sheets("Sheet 2")
With Sheets("Sheet 1")
r = Application.Max(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(Rows.Count, 2).End(xlUp).Row) 'Defines # of rows to apply If/Then to?'
For r = Application.Sum(v) To 2 Step -1 'Each time If/Then is ran, reduce # of rows to apply If/Then to?'
If CBool(Application.CountIfs(ws2.Columns(1), .Cells(r, 1).Value, ws2.Columns(2), .Cells(r, 2).Value)) Then _
.Rows(r).EntireRow.Copy s3.Cells(K, 1) 'Compares value in (r)row column 1 and 2, sheet2, to sheet1(activesheet), if equal THEN copies entire (r)row onto sheet3 @ next empty row'
'take (r)row of match and copy value of column 3 and 4 sheet2 onto the end of previously pasted row on sheet3'
Next r
End With
fìn:

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub}

Variatus Variatus · Accepted Answer · 2017-08-02T03:43:05

The code below doesn't do everything just the way your attempt suggests but I wrote it in very plain language so that you will surely be able to teak it back into your track where it has transgressed to where it shouldn't go.

Sub MatchNameAndInfo()
    ' 02 Aug 2017

    Dim WsInput As Worksheet
    Dim WsInfo As Worksheet
    Dim WsOutput As Worksheet
    Dim Rl As Long                              ' Last row of WsInput
    Dim R As Long                               ' WsInput/WsInfo row counter
    Dim Tmp1 As String, Tmp2 As String          ' Clm 1 and Clm2 Input values
    Dim Cmp1 As String, Cmp2 As String          ' Clm 1 and Clm2 Info values

    Set WsInput = Worksheets("Krang (Input)")
    Set WsInfo = Worksheets("Krang (Info)")
    Set WsOutput = Worksheets("Krang (Output)")

    Application.ScreenUpdating = False
    With WsInput
        Rl = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, _
                             .Cells(.Rows.Count, 2).End(xlUp).Row)
        If Rl < 2 Then Exit Sub

        For R = 2 To Rl                         ' define each input row in turn
            Tmp1 = Trim(.Cells(R, 1).Value)
            Tmp2 = Trim(.Cells(R, 2).Value)
            Cmp1 = Trim(WsInfo.Cells(R, 1).Value)
            Cmp2 = Trim(WsInfo.Cells(R, 2).Value)
            If StrComp(Tmp1 & Tmp2, Cmp1 & Cmp2, vbTextCompare) = 0 Then
                TransferData R, WsInfo, WsOutput
            End If
        Next R
    End With

    Application.ScreenUpdating = True
End Sub

Private Function TransferData(R As Long, _
                              WsInfo As Worksheet, _
                              WsOut As Worksheet)
    ' 02 Aug 2017

    Dim Rng As Range
    Dim Rt As Long                              ' target row

    With WsInfo
        Set Rng = .Range(.Cells(R, 1), .Cells(R, 4))
    End With

    With WsOut
        Rt = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 2)
        Rng.Copy Destination:=.Cells(Rt, 1)
    End With
End Function

Match, Copy, and Add Values between Sheets

1 Answers