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

这是我到目前为止所做的，现在没有做任何事情，但我已经从一些工作宏拼凑起来试图完成我所追求的目标。我无法找到“Copy Sheet2 Row column 3 + 4 @ previous of Sheet of Sheet on 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

表格之间的匹配，复制和添加值

1 个答案: