sort alphabetically and numerically, then sort rows

Hi Luke -

This probably isn't the most elegant solution, but it should get you out of trouble for now .. Select your unsorted sheet, then run this and it will add a sheet at the end and sort per your example. I've reposted your file with the code in it.

I did find two cases where there are 5 values that are equal, not just 4 as in your sorted sheet, but perhaps that's just this test data ... Also - you have to remove the blank rows at the top and I've assumed a header row, but I'm sure you can tidy that up if you need to.

Hope it helps anyway ...

MM.

Sub CompareAndSort()

Dim cel As Range
Dim lngOriginalRows As Long
Dim lngMaxPossibleRows As Long
Dim i As Long
Dim j As Integer
Dim k As Integer
Dim strValue As String
Dim strNextValue As String

    lngOriginalRows = Range("A1").CurrentRegion.Rows.Count
    lngMaxPossibleRows = (lngOriginalRows - 1) * 4
    
    Range("A2:D" & lngOriginalRows).Select
    
    For Each cel In Selection
        If cel.Value <> Empty Then
            i = i + 1
            Range("F" & i).Value = cel.Value
        End If
    Next cel
    lngMaxPossibleRows = i
    
    Range("F:F").Sort Key1:=Columns("F"), header:=xlNo, dataoption1:=xlSortTextAsNumbers
    For i = 1 To lngMaxPossibleRows
        If IsNumeric(Range("F" & i).Value) Then
            'nothing:
        Else
            'first text instance found:
            Range("F1:F" & i - 1).Cut Destination:=Range("F" & lngMaxPossibleRows + 1)
            GoTo TextFound
        End If
    Next i

TextFound:
    
    Range("F1:F" & i - 1).Delete shift:=xlUp
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    
    Application.ScreenUpdating = False
    
    j = 1
    For i = 1 To lngMaxPossibleRows
        Worksheets(1).Activate
        strValue = Range("F" & i).Value
        strNextValue = Range("F" & i + 1).Value
        If strNextValue = strValue Then
            'nothing.
        Else
            Sheets(1).Range("F" & j & ":F" & i).Copy
            Sheets(Sheets.Count).Activate
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            ActiveCell.Offset(1, 0).Select
            Application.CutCopyMode = False
            j = i + 1
        End If
    Next i
    
    Sheets(1).Range("F1").EntireColumn.Delete
    i = Sheets(Sheets.Count).Range("A1").CurrentRegion.Rows.Count
    j = Sheets(Sheets.Count).Range("A1").CurrentRegion.Columns.Count
    
    Range(Cells(1, 1), Cells(i, j)).Select
    For Each cel In Selection
        If cel.Value = Empty Then cel.Interior.Color = 0
    Next cel
    Range("A1").Select
    
    Application.ScreenUpdating = True
    
End Sub

Hi Luke -

(for anyone else following this thread, I received a more detailed explanation of what needed to happen, which basically meant that the data needed to remain associated with it's original header; the other issue was that this is being run on a large data set and was hanging...)

I've completely reworked this so that the sorting is now all done in a series of arrays rather than in a sheet, which makes it run much faster and should mean you won't have the hanging issue any more. On the dataset you sent me, it runs on my machine for the largest dataset in less than a second.

In the sort process, I've kept the data in each column associated with its original header as you explained to me ... Anyway - see below & let me know if it's what you need.

Option Explicit
Option Base 0

Sub SortRangeInArray()

Dim intFirstDataRow As Integer
Dim lngRegionRows As Long
Dim lngRegionCols As Long

Dim cel As Range
Dim sht As Worksheet

Dim varHeaderArray As Variant
Dim varArray As Variant
Dim varSortedArray As Variant
Dim var2DimArray As Variant
Dim var2DimSortedArray As Variant
Dim varFinal2DimSortedArray As Variant
Dim strCol As Variant

Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long

Dim lngCountSorted As Long
Dim lngLowestIndex As Long

Dim intOccurrences As Integer
Dim intUniqueValues As Integer
Dim intFound As Integer
Dim intRowsInFinalArray As Integer

Dim strSheetToSort As String
Dim strSortedSheet As String
Dim strMessage As String

Dim booBlankInRowFound As Boolean
Dim booRowAlreadyAdded As Boolean
    
    'initialise:
    strSheetToSort = ActiveSheet.Name
    strSortedSheet = strSheetToSort & " - SORTED"
    strMessage = "An unspecified error has occurred."
    intFirstDataRow = 5
    lngRegionRows = Range("A" & intFirstDataRow).CurrentRegion.Rows.Count
    lngRegionCols = Range("A" & intFirstDataRow).CurrentRegion.Columns.Count
    ReDim varHeaderArray(lngRegionCols)
    ReDim varArray(lngRegionRows * lngRegionCols)
    
    'get the headers from the active sheet:
    i = Range("A1").End(xlDown).Row
    If i = 65536 Then
        strMessage = "There is no data in sheet " & ActiveSheet.Name
        GoTo ErrorExit
    ElseIf i = intFirstDataRow Then
        For j = 1 To lngRegionCols
            varHeaderArray(j) = "Column " & j
        Next j
    Else
        For j = 1 To lngRegionCols
            varHeaderArray(j) = CStr(Cells(i, j).Value)
        Next j
    End If
    
    'sort each column separately of the others:
    ReDim var2DimArray(lngRegionRows, lngRegionCols)
    
    For x = 1 To lngRegionCols     'for each column ...
        'sort the column:
        strCol = Cells(1, x).Address
        strCol = Split(strCol, "$", -1, vbTextCompare)
        strCol = strCol(1)
         Range(strCol & intFirstDataRow & ":" & strCol & lngRegionCols).Sort Key1:=Range(strCol & intFirstDataRow), _
            Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=True, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
        i = 0
        For Each cel In Range(strCol & intFirstDataRow & ":" & strCol & lngRegionRows + intFirstDataRow - 1)
            If cel.Value <> Empty And cel.Value <> var2DimArray(i, x) Then
                i = i + 1
                var2DimArray(i, x) = CStr(cel.Value)
            End If
        Next cel
    Next x
    
    'read all non-blank data into a 1-D array:
    i = 0
    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

    'find the lowest value in the raw array:
    ReDim Preserve varArray(i)
    ReDim varSortedArray(i)
    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
                    lngLowestIndex = k
                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
                    If intOccurrences = lngRegionCols Then GoTo GetNextArrayValue
                    'NB: assumes there can only be 1 of each value per column!
                    '    if this is not true, then delete this IF statement.
                Else
                    'do nothing:
                End If
            End If
GetNextArrayValue:
        Next k
        
        lngCountSorted = lngCountSorted + intOccurrences
        intUniqueValues = intUniqueValues + 1
        
        'remove the "lowest value" just copied to the sorted array:
        intFound = 0
        For x = lngLowestIndex To i
            If varArray(x) = varSortedArray(j) Then
                varArray(x) = Empty
                intFound = intFound + 1
            End If
            If intFound = intOccurrences Then Exit For
        Next x
                
    Next j
    
    'remove blanks at end of the sorted 1-D array:
    For i = 1 To UBound(varSortedArray)
        If varSortedArray(i) <> Empty Then
            'keep looking:
        Else
            ReDim Preserve varSortedArray(i - 1)
            Exit For
        End If
    Next i
    
    'create the new sorted 2-D array with unique values in each primary index:
    '(if all values in the grid are unique, then the maximmum possible number
    ' of rows in the new array is the number of total values in the grid):
    ReDim varFinal2DimSortedArray(UBound(varArray), lngRegionCols)
    x = UBound(varSortedArray)
    intRowsInFinalArray = 0
    For i = 1 To x
        booRowAlreadyAdded = False
        For j = 1 To lngRegionRows
            For k = 1 To lngRegionCols
                If var2DimArray(j, k) = Empty Then
                    'skip:
                ElseIf var2DimArray(j, k) = varSortedArray(i) Then
                    If booRowAlreadyAdded = False Then
                        intRowsInFinalArray = intRowsInFinalArray + 1
                        booRowAlreadyAdded = True
                    End If
                    varFinal2DimSortedArray(intRowsInFinalArray, k) = varSortedArray(i)
                End If
            Next k
        Next j
    Next i
    
    'display the sorted data in a new sheet:
    Worksheets.Add after:=Worksheets(strSheetToSort)
    j = 0
    Application.ScreenUpdating = False
    
CheckSheetNames:
    j = j + 1
    For Each sht In Sheets
        If sht.Name = strSortedSheet Then
            strSortedSheet = strSortedSheet & j
            GoTo CheckSheetNames
        End If
    Next sht
    ActiveSheet.Name = strSortedSheet
    
    'write headers:
    For i = 1 To UBound(varHeaderArray)
        Worksheets(strSortedSheet).Cells(1, i) = varHeaderArray(i)
    Next i
    Worksheets(strSortedSheet).Range("A1").EntireRow.Font.Bold = True
    
    'write data:
    For i = 1 To UBound(varSortedArray)
        booBlankInRowFound = False
        Application.StatusBar = "Preparing output " & i & " of " & UBound(varSortedArray)
        For j = 1 To lngRegionCols
            If varFinal2DimSortedArray(i, j) = Empty Then
                booBlankInRowFound = True
                Worksheets(strSortedSheet).Cells(i + 1, j).Interior.Color = vbBlack
            Else
                Worksheets(strSortedSheet).Cells(i + 1, j) = varFinal2DimSortedArray(i, j)
            End If
        Next j
        If booBlankInRowFound = False Then Worksheets(strSortedSheet).Range(Cells(i + 1, 1), Cells(i + 1, lngRegionCols)).Interior.Color = vbGreen
    Next i
    
    ActiveWindow.Zoom = 85
    ActiveSheet.Columns.AutoFit
    ActiveSheet.Cells.VerticalAlignment = xlCenter

    GoTo NormalExit

ErrorExit:
    MsgBox (strMessage)

NormalExit:
    Application.ScreenUpdating = True
    Application.StatusBar = False
    
End Sub

Hi Luke - I just opened & ran it and it worked fine ... Since you're on XL2000, perhaps lookup your VBA help under Sort and see what the allowable values are for dataoption1 ... it may have changed in 8 years