Excel 宏：如何在根据工作表名称创建唯一标识符时将信息从多张工作表复制到一张工作表

Question

这是我的数据集。

表 1：

  FirstName       LastName       Email            Phone
  james           jones          [email protected]     555-5555
  karen           johnson        [email protected]     555-5556
  tony            brown          [email protected]     555-5557

表 2：

  FirstName       LastName       Email            Phone          Goal
  james           jones          [email protected]     555-5555        200
  karen           johnson        [email protected]   555-5556        500
  peter           white          [email protected]     555-5558       1200

表 3：

  FirstName       LastName       Email            Phone
  karen           johnson        [email protected]     555-5556
  peter           white          [email protected]     555-5558
  tim             thomson        [email protected]     555-5559

表 4（结果）：

  FirstName       LastName       Email            Phone       Sheet2   Sheet3   Goal 
  james           jones          [email protected]     555-5555    yes      no       200
  karen           johnson        [email protected],    555-5556    yes      yes      500
                                 [email protected]
  tony            brown          [email protected]     555-5557    no       no
  peter           white          [email protected]     555-5558    yes      yes      1200
  tim             thomson        [email protected]     555-5559    no       yes

请参阅表 2 有一些额外的信息，我想保留在最终表中，第一张表不需要在最终表中列出，并且有些人将会有一些不匹配的数据（如上例中的 karen johnson 所示）。对于任何三个匹配的数据点（即 - 第一个 + 最后一个 + 电话或第一个 + 最后一个 + 电子邮件），我们可以假设匹配。

Answer 1

将下面的代码添加到您的工作簿中。运行“MoveDataToSheet4”后，您将获得sheet4 上描述的输出。

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 的输出如下图所示。