Excelマクロ：シート名から一意の識別子を作成しながら、複数のシートの情報を1つにコピーする方法

Question

ここに自分のデータセットがあります。

シート1：

FirstName  LastName  Email   Phone 
    james   jones   jj@email.com  555-5555 
    karen   johnson  kj@email.com  555-5556 
    tony   brown   tb@email.com  555-5557 

シート2：

FirstName  LastName  Email   Phone   Goal 
    james   jones   jj@email.com  555-5555  200 
    karen   johnson  kjoh@email.com 555-5556  500 
    peter   white   pw@email.com  555-5558  1200 

シート3：

FirstName  LastName  Email   Phone 
    karen   johnson  kj@email.com  555-5556 
    peter   white   pw@email.com  555-5558 
    tim    thomson  tt@email.com  555-5559 

シート4（結果）：

FirstName  LastName  Email   Phone  Sheet2 Sheet3 Goal 
    james   jones   jj@email.com  555-5555 yes  no  200 
    karen   johnson  kj@email.com, 555-5556 yes  yes  500 
           kjoh@email.com 
    tony   brown   tb@email.com  555-5557 no  no 
    peter   white   pw@email.com  555-5558 yes  yes  1200 
    tim    thomson  tt@email.com  555-5559 no  yes 

シート2には、最後のシートに残しておきたいいくつかの追加情報があります。最初のシートは最終シートに記載する必要はなく、一部の人々は不一致のデータを持っています（上記の例ではkaren johnson ）。一致する3つのデータポイント（つまり、ファースト+ラスト+電話またはファースト+ラスト+メール）を使用すると、一致すると見なすことができます。

Answer 1

以下のコードをブックに追加してください。 "MoveDataToSheet4"を実行した後、シート4で説明したように出力されます。

Option Explicit 

Sub MoveDataToSheet4() 
Dim rr As Range 
Dim dta() As Variant 
Dim topR As Long, foundrow As Long, mrow As Long 
Dim x As Integer 
Dim LastR As Long 
Dim i As Integer 
Dim ii As Integer 
Dim OutPut() As Variant 
Dim nmdRng As Range 

Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet 
Set ws = ThisWorkbook.Worksheets("Sheet1") 
Set ws2 = ThisWorkbook.Worksheets("Sheet2") 
Set ws3 = ThisWorkbook.Worksheets("Sheet3") 
Set ws4 = ThisWorkbook.Worksheets("Sheet4") 

With ws 
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row 
    ReDim dta(1 To 6, 2 To LastR) 
    For Each rr In .Range("A2:E" & LastR) 
     dta(rr.Column, rr.Row) = rr.Value 
    Next rr 
End With 

With ws2 
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row 
    topR = UBound(dta, 2) 
    ReDim Preserve dta(1 To 6, 2 To (topR + (LastR - 1))) 
    For Each rr In .Range("A2:E" & LastR) 
     dta(rr.Column, rr.Row + topR - 1) = rr.Value 
     If rr.Column = 5 Then 
      dta(6, rr.Row + topR - 1) = "Sheet2" 
     End If 
    Next rr 
End With 

With ws3 
    LastR = .Cells(.Rows.Count, "A").End(xlUp).Row 
    topR = UBound(dta, 2) 
    ReDim Preserve dta(1 To 6, 2 To (topR + (LastR - 1))) 
    For Each rr In .Range("A2:E" & LastR) 
     dta(rr.Column, rr.Row + topR - 1) = rr.Value 
     If rr.Column = 5 Then 
      dta(6, rr.Row + topR - 1) = "Sheet3" 
     End If 
    Next rr 
End With 

ReDim OutPut(1 To UBound(dta), 1 To 1) 
For i = LBound(dta, 2) To UBound(dta, 2) 

foundrow = Empty 
For mrow = LBound(OutPut, 2) To UBound(OutPut, 2) 
If OutPut(1, mrow) = dta(1, i) And OutPut(2, mrow) = dta(2, i) And i <> mrow Then 
    foundrow = mrow 
    Exit For 
End If 
Next mrow 

Dim hold As Variant 

If foundrow <> Empty Then 
'it exists here and one other place so let's just merge them now 
'merge it 
    For x = LBound(OutPut) To UBound(OutPut) 'for each column 
     If x = 1 Or x = 2 Then 
      OutPut(x, foundrow) = dta(x, i) 
     ElseIf x = 3 Or x = 4 Or x = 5 Or x = 6 Then 
      If dta(x, i) <> OutPut(x, foundrow) Then 
       OutPut(x, foundrow) = dta(x, i) & "," & OutPut(x, foundrow) 
      End If 
     End If 
    Next x 
Else 
    ReDim Preserve OutPut(1 To UBound(dta), 1 To UBound(OutPut, 2) + 1) 
    For x = LBound(OutPut) To UBound(OutPut) 'for each column 
     OutPut(x, UBound(OutPut, 2)) = dta(x, i) 
    Next x 
End If 
Next i 
Dim Rng2 As Range 
With ws4 
    For Each Rng2 In .Range("A2:F" & UBound(OutPut, 2)) 
     Rng2.Value = OutPut(Rng2.Column, Rng2.Row) 
     If Rng2.Column = 5 Then 
      Rng2.Value = Replace(OutPut(Rng2.Column, Rng2.Row), ",", "") 
     ElseIf Rng2.Column = 6 Then 
      If InStr(Rng2.Value, "Sheet3") Then 
       .Cells(Rng2.Row, Rng2.Column + 1) = "Yes" 
       'Rng2.Value = "" 
      Else 
       .Cells(Rng2.Row, Rng2.Column + 1) = "No" 
      End If 
      If InStr(Rng2.Value, "Sheet2") Then 
       Rng2.Value = "Yes" 
       Else 
       Rng2.Value = "No" 
      End If 

     End If 
    Next Rng2 
End With 
End Sub 

Sheet4の出力は、下の画像のようになります。