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中有一些额外的信息我想保留在最终的表格中，第一张表格不需要列在最终的表格中，而且有些人会有一些不匹配的数据（就像凯伦约翰逊一样）上面的例子）。对于任何三个匹配的数据点（即 - 第一个+最后一个+电话或第一个+最后一个+电子邮件），我们可以假设匹配。

Answer 1

将以下代码添加到您的工作簿中。运行＆＃34; MoveDataToSheet4＆＃34;后，您将获得在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的输出将如下图所示。

Output of Sheet4

Excel宏：如何从工作表名称创建唯一标识符时将多个工作表中的信息复制到一个

1 个答案: