在工作表之间匹配、复制和添加值

Question

希望将 sheet2 上同一行的第 1 列和第 2 列的值与 sheet1 上同一行的第 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