Excel aligning lists

Question

I have files where the contents look generally like this, with a bunch of columns that are cut off.

Here is a general idea of how the files look:

I need to combine these files into one spreadsheet based on the accession values so that they look something like this:

Note how the results that are not matched are at the end. There will most likely be cases where for example there are matching lines in files 1 and 2 that are not in file 3 and others where there are matching lines in files 2 and 3 but not one.

I hope I explained what is needed, please let me know if more examples/clarification is needed.

Answer 1

Put this in a regular vba module in the workbook where the merged results will reside.
Edit the constants and run.

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