シート間の値の一致、コピー、および追加

Question

シート1の同じ行の列1 & 2と同じ列の値2とシート2の同じ行の2とを照合します。次に、sheet3の次の空白行に、sheet3のマッチした行全体をコピーし、同じ行の列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 

は、私がこれまでのところ、これは今何もしませんしているが、私は試してみて、私が後だものを達成するために、いくつかの作業マクロからそれを一緒につなぎているものです。私は "Sheet3の行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