Match, Copy, and Add Values between Sheets - vba

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

Answer 1

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