Макрос Excel: как скопировать информацию с нескольких листов на один при создании уникального идентификатора из имени листа - PullRequest
Новая
       26

Макрос Excel: как скопировать информацию с нескольких листов на один при создании уникального идентификатора из имени листа

0 голосов
/ 26 января 2012

Вот мой набор данных.

Лист 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 есть некоторая дополнительная информация, которую я хотел бы сохранить на последнем листе, первый лист не обязательно должен быть указан на последнем листе, и что у некоторых людей будут некоторые несопоставимые данные (как в случае с Карен Джонсон в пример выше). С любыми тремя совпадающими точками данных (то есть - первый + последний + телефон или первый + последний + адрес электронной почты) мы можем предположить совпадение.

1 Ответ

1 голос
/ 28 января 2012

Добавьте приведенный ниже код в вашу книгу. После запуска 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 будет выглядеть как на рисунке ниже.

Output of Sheet4

...