Align Rows Comparing Multiple Columns

Hi deaerator ... OK, I think this will do what you're after. The code is below; just paste it into the workbook object, and I've attached the workbook I used to test it. This is the main control module:

Option Explicit
Option Base 1

Sub Control()
Dim intFirstCol As Integer, intLastCol As Integer, intIDRow As Integer
Dim intCountDatasets As Integer, intCountUniqueIDs As Integer
Dim intColsPerDataset As Integer
Dim lngLastRow As Long, i As Long, j As Long, k As Long
Dim strIDLabel As String, strInputSheet As String, strOutputSheet As String
Dim varIDCols As Variant, varIDs As Variant, varData As Variant
Dim cel As Range
    
    'initialise:
    strIDLabel = "ID_id1"
    strInputSheet = "Input"
    strOutputSheet = "Output"
    intIDRow = 2    'must be 2 or greater.
    intColsPerDataset = 5
    intLastCol = Worksheets(strInputSheet).Cells.SpecialCells(xlCellTypeLastCell).Column
    lngLastRow = Worksheets(strInputSheet).Cells.SpecialCells(xlCellTypeLastCell).Row
    
    'store the columns of each dataset that has the IDs in them:
    Worksheets(strInputSheet).Activate
    ReDim varIDCols(intLastCol)
    Call GetIDCols(strInputSheet, strIDLabel, intIDRow, intLastCol, varIDCols)
    intCountDatasets = UBound(varIDCols)

    'get all unique IDs across all datasets:
    ReDim varIDs(intCountDatasets * lngLastRow)
    intCountUniqueIDs = 0
    Call GetUniqueIDs(intCountDatasets, lngLastRow, intIDRow, varIDCols, varIDs, intCountUniqueIDs)
    ReDim Preserve varIDs(intCountUniqueIDs)
    
    'search the sheet & store all data sequentially against unique IDs and dataset number:
    ReDim varData(UBound(varIDs), intCountDatasets, intColsPerDataset)
    For i = LBound(varIDs) To UBound(varIDs)
        With Worksheets(strInputSheet).Cells
            Set cel = .Find(what:=varIDs(i), lookat:=xlWhole, after:=Cells(intIDRow, intLastCol), LookIn:=xlValues)
            intFirstCol = cel.Column
            While Not cel Is Nothing
                For j = 1 To intCountDatasets
                    If cel.Column = varIDCols(j) Then Exit For
                Next j
                For k = 1 To intColsPerDataset
                    varData(i, j, k) = cel.Offset(0, k - 1).Value
                Next k
                Set cel = .FindNext(cel)
                If cel.Column = intFirstCol Then GoTo GetNextID
            Wend
        End With
GetNextID:
    Next i
    
    'prepare the output sheet:
    Call ResetOutputSheet(strInputSheet, strOutputSheet, intIDRow)
        
    'write the data to the output sheet:
    For i = LBound(varIDs) To UBound(varIDs)
        For j = 1 To intCountDatasets
            For k = 1 To intColsPerDataset
                Worksheets(strOutputSheet).Cells(intIDRow + i, varIDCols(j)).Offset(0, k - 1).Value = varData(i, j, k)
            Next k
        Next j
    Next i

End Sub

And these are the others the control module calls:

Sub GetIDCols(strSheet, strLookFor, intRow, intCol, varCols)
Dim cel As Range
Dim i As Integer
    i = 1
    With Worksheets(strSheet).Range(Cells(1, 1), Cells(intRow, intCol))
        Set cel = .Find(what:=strLookFor, LookIn:=xlValues, after:=Cells(intRow - 1, intCol))
        If Not cel Is Nothing Then
            varCols(i) = cel.Column
            Do
                i = i + 1
                Set cel = .FindNext(cel)
                If cel.Column = varCols(1) Then Exit Do
                varCols(i) = cel.Column
            Loop While Not cel Is Nothing
        End If
        ReDim Preserve varCols(i - 1)
    End With
End Sub

Sub GetUniqueIDs(intDSCount, lngLastRow, intIDRow, varCols, varUniqueIDs, intCount)
Dim i As Long, j As Long, k As Long
Dim cel As Range
    For i = 1 To intDSCount
        For j = 1 To lngLastRow
            Set cel = Cells(intIDRow + j, varCols(i))
            If cel.Value <> Empty Then
                'see if it's been loaded yet:
                For k = LBound(varUniqueIDs) To UBound(varUniqueIDs)
                    If varUniqueIDs(k) = cel.Value Then
                        'already loaded; get next one in dataset:
                        Exit For
                    ElseIf varUniqueIDs(k) = Empty Then
                        'if it's the last one, then it's not there yet:
                        intCount = k
                        varUniqueIDs(intCount) = cel.Value
                        Exit For
                    End If
                Next k
            Else
                Exit For
            End If
        Next j
    Next i
End Sub

Sub ResetOutputSheet(strInputSheetName, strOutputSheetName, intHeaderRow)
Dim wsh As Worksheet
    For Each wsh In Worksheets
        If UCase(Trim(wsh.Name)) = UCase(Trim(strOutputSheetName)) Then
            wsh.Cells.Clear
            GoTo SheetPrepDone
        End If
    Next wsh
    
    'if there is no output sheet, create one:
    Worksheets.Add after:=Worksheets(strInputSheetName)
    ActiveSheet.Name = strOutputSheetName
    ActiveWindow.Zoom = 85
    Worksheets(strInputSheetName).Activate
    
SheetPrepDone:
    Worksheets(strInputSheetName).Range("1:" & intHeaderRow).Copy Destination:=Worksheets(strOutputSheetName).Range("1:" & intHeaderRow)
    
End Sub

Hope that helps. MM.

Thank You MM. Works like a charm. Thanks so Much...