Align Rows Comparing Multiple Columns

Hi,
I would like to align rows in an spreadsheet. The spreadsheet has multiple columns which has data which needs to be aligned. I have added a spreadsheet with 2 tabs . One is input tab and the other is output tab. I would like to get the data formatted in the input tab to the one which looks like in output tab.

I would like to run a macro to get the output, the number of rows in each column are not fixed. they change depending upon the data.

Thanks in Advance.

Here's an alternative; it's a generic sorting routine that will produce output for any matrix of data in an active sheet and sort by numbers, then capital letters then lower case letters ... and displays the linear list of values in a column to the right of your data and also the 2 dimensional sorted matrix underneath your data.

Sub SortRangeInArray()
Dim intFirstDataRow As Integer
Dim cel As Range
Dim varArray As Variant
Dim varSortedArray As Variant
Dim var2DimSortedArray As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
Dim lngRegionRows As Long
Dim lngRegionCols As Long
Dim intOccurrences As Integer
Dim intHighestOccurrence As Integer
Dim intUniqueValues As Integer
Dim lngCountSorted As Long
Dim varLowestFound As Variant

    'initialise:
    intFirstDataRow = 1
    lngRegionRows = Range("A" & intFirstDataRow).CurrentRegion.Rows.Count
    lngRegionCols = Range("A" & intFirstDataRow).CurrentRegion.Columns.Count
    ReDim varArray(lngRegionRows * lngRegionCols)
    ReDim varSortedArray(UBound(varArray))
    
    i = 0
    intOccurrences = 0
    intHighestOccurrence = 0
    'read in data (skip empty cells):
    For Each cel In Range("A" & intFirstDataRow).CurrentRegion
        If cel.Value <> Empty Then
            i = i + 1
            varArray(i) = CStr(cel.Value)
        End If
    Next cel

    ReDim Preserve varArray(i)
    
    'sort in array:
    intOccurrences = 0
    For j = 1 To i
        For k = 1 To i
            If varSortedArray(j) = Empty Then
                If varArray(k) <> Empty Then
                    varSortedArray(j) = varArray(k)
                    intOccurrences = 1
                ElseIf varArray(k) = Empty Then
                    GoTo GetNextArrayValue
                End If
            ElseIf varArray(k) <> Empty Then
                If varArray(k) < varSortedArray(j) Then
                    varSortedArray(j) = varArray(k)
                    intOccurrences = 1
                ElseIf varArray(k) = varSortedArray(j) Then
                    intOccurrences = intOccurrences + 1
                End If
            End If
GetNextArrayValue:
        Next k
        
        'populate the sorted array with the lowest found:
        varLowestFound = varSortedArray(j)
        For x = lngCountSorted + 1 To lngCountSorted + intOccurrences
            varSortedArray(x) = varLowestFound
        Next x
        lngCountSorted = lngCountSorted + intOccurrences
        If intOccurrences > intHighestOccurrence Then intHighestOccurrence = intOccurrences
        intUniqueValues = intUniqueValues + 1
        
        'set j to the last position taken in the sorted array:
        j = lngCountSorted
        
        'remove the lowest found values from the raw array:
        For x = 1 To i
            If varArray(x) = varLowestFound Then varArray(x) = Empty
        Next x
    Next j
    
    'show the sorted array in a spare column:
    For i = 1 To UBound(varSortedArray)
        Cells(i, intHighestOccurrence + 2).Value = varSortedArray(i)
    Next i

    'sort the 1-dim array into a 2-dim array:
    k = 0
    ReDim var2DimSortedArray(intUniqueValues, intHighestOccurrence)
    For i = 1 To intUniqueValues
        For j = 1 To intHighestOccurrence
            k = k + 1
            var2DimSortedArray(i, j) = varSortedArray(k)
            If k = lngCountSorted Then
                Exit For
            ElseIf varSortedArray(k + 1) <> varSortedArray(k) Then
                Exit For
            Else
                'nothing - continue:
            End If
        Next j
    Next i

    'show the sorted 2-D array under the original range:
    For i = 1 To intUniqueValues
        For j = 1 To intHighestOccurrence
            If var2DimSortedArray(i, j) = Empty Then Exit For
            Cells(i + lngRegionRows + 2, j) = var2DimSortedArray(i, j)
        Next j
    Next i

End Sub

Hope that helps. MM.

OK - an attachment always helps My question is: Is the first ID for each set of data unique within the individual data? That is, for each dataset SP1, SP2, SU1 etc .. can there ever be two ID_id1 values the same? Such as - having ID_id1 = 40_1 twice, with different combinations of the other IDs (ID, id1, id2)?

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...