Выравнивающие списки Excel

Question

У меня есть файлы, содержимое которых выглядит примерно так, с кучей столбцов, которые обрезаются.

Вот общее представление о том, как выглядят файлы:

Мне нужно объединить эти файлы в одну электронную таблицу на основе значений доступа, чтобы они выглядели примерно так:

Обратите внимание, как результаты, которые не совпадают, находятся в конце. Скорее всего, будут случаи, когда, например, в файлах 1 и 2 есть совпадающие строки, которых нет в файле 3, а в других - совпадающие строки в файлах 2 и 3, но не одна.

Я надеюсь, что объяснил, что нужно, пожалуйста, дайте мне знать, если нужно больше примеров / разъяснений.

Answer 1

Поместите это в обычный модуль vba в рабочей книге, где будут находиться объединенные результаты.
Отредактируйте константы и запустите.

Option Explicit

' Add a dialogue (Application.FileDialog) for file selection
'   and InputBox for sheet selection
'   Or a Form to select the files & their respective sheets.
'
Private Const wbName1 = "file1.xlsx"
Private Const wsName1 = "Sheet1"
Private Const wbName2 = "file2.xlsx"
Private Const wsName2 = "Sheet1"
Private Const wbName3 = "file3.xlsx"
Private Const wsName3 = "Sheet1"
Private Const cStart = "A2" ' data colum and row start
Private Const outputSheet = "Sheet1"

Public Sub MergeFiles()

    Dim wbName(0 To 2) As String, wsName(0 To 2) As String
    Dim r(0 To 2) As Range
    Dim c(1 To 7) As Collection

    Dim z As Long
    Dim w As Long
    Dim i As Long, j As Long
    Dim startColumn As String
    Dim errorNo As Long
    Dim a As Variant, b As Variant, v As Variant

    For i = 7 To 1 Step -1
        Set c(i) = New Collection
    Next i

    wbName(0) = wbName1: wbName(1) = wbName2: wbName(2) = wbName3
    wsName(0) = wsName1: wsName(1) = wsName2: wsName(2) = wsName3
    startColumn = Split(Range(cStart).Address(True, False), "$")(0)

    For w = 0 To 2
        On Error Resume Next
        Workbooks.Open fileName:=wbName(w), ReadOnly:=True
        Err.Clear
        On Error Resume Next
        With Workbooks.Item(Right(wbName(w), Len(wbName(w)) - InStrRev(wbName(w), _
            Application.PathSeparator))).Worksheets(wsName(w))
            If Err.Number <> 0 Then
                Err.Clear
                On Error GoTo 0
                MsgBox "Could not open workbook file " & w + 1 & ": '" & wbName(w) & "'"
                CloseAll r
                Exit Sub
            End If
            Set r(w) = .Range(cStart, startColumn & _
                .Range(cStart).SpecialCells(xlCellTypeLastCell).Row)
        End With
    Next w
    On Error GoTo 0

    For w = 0 To 2
        For i = 1 To r(w).Count
            If r(w)(i) <> "" Then
                a = Application.Match(r(w)(i), r((w + 1) Mod 3), 0)
                b = Application.Match(r(w)(i), r((w + 2) Mod 3), 0)
                If w = 0 Then
                    If Not IsError(a) Then
                        If Not IsError(b) Then
                            c(7).Add Array(i, a, b)
                        Else
                            c(6).Add Array(i, a, 0)
                        End If
                    ElseIf Not IsError(b) Then
                        c(5).Add Array(i, 0, b)
                    Else
                        c(3).Add Array(i, 0, 0)
                    End If
                ElseIf w = 1 Then
                    If IsError(b) Then
                        If Not IsError(a) Then
                            c(4).Add Array(0, i, a)
                        Else
                            c(2).Add Array(0, i, 0)
                        End If
                    End If
                ElseIf IsError(a) And IsError(b) Then
                   c(1).Add Array(0, 0, i)
                End If
            End If
        Next i
    Next w
    z = 3
    With ThisWorkbook.Worksheets(outputSheet).Range("A1")
        For w = 0 To 2
             .Cells(1, w * 5 + 1) = r(w).Parent.Parent.Name
        Next w
        For w = 0 To 2
            For j = 1 To 3
                .Cells(2, w * 5 + j) = r(w).Cells(0, j) ' column header
            Next j
        Next w
        z = 3
        For i = 7 To 1 Step -1
            For Each v In c(i)
                For w = 0 To 2
                    If v(w) <> 0 Then
                        For j = 1 To 3
                            .Cells(z, w * 5 + j) = r(w).Cells(v(w), j)
                        Next j
                    End If
                Next w
                z = z + 1
            Next v
        Next i
    End With
    CloseAll r
End Sub

Private Sub CloseAll(ByRef r() As Range)
    Dim w As Variant
    For Each w In r
        If Not w Is Nothing Then
            With w.Parent.Parent
                On Error Resume Next
                If .Saved Then .Close
            End With
        End If
    Next w
End Sub