表單之間的匹配，複製和添加值

Question

查看錶單2上同一行的第1列& 2的值與第1列上同一行的列1 & 2的值相匹配。然後，將sheet1匹配的整行復制到sheet3的下一個空行上，將同一行sheet2的第3 + 4列的值複製到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 

這裏是我到目前爲止，這並沒有做任何事情，但現在我已經從幾道宏一起拼湊，試圖達到我後。我一直沒有找到「複製Sheet2行列3 + 4 @以前粘貼在Sheet3行上」的例子，所以我只是在我認爲代碼應該去的行上有一個描述。

{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

下面的代碼不會做的一切只是方式你嘗試建議，但我寫的非常通俗易懂的語言，這樣你就一定能柚木它放回你的賽道，它違背了到它不應該去。

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