How to sort a mismatched spreadsheet

[cricketjdw]

This is a sample spreadsheet. I am needing all the 1900/Hollan to line up within the same row and then 1901/Wright and so on. Is there a way to sort this mess?

NUMBER	NAME	NUMBER	NAME	NUMBER	NAME
1900	HOLLAN	1901	WRIGHT	1902	WEST
1901	WRIGHT	1902	WEST	1903	EAST
1902	WEST	1903	EAST	1904	NORTH
1903	EAST	1904	NORTH	1905	RIGHT
1904	NORTH	1905	RIGHT	1906	LEFT
1905	RIGHT	1906	LEFT	1907	FAX
1906	LEFT	1907	FAX	1908	COVER
1907	FAX	1908	COVER	1909	SENT
1908	COVER	1909	SENT	1910	ITEMS
1909	SENT	1910	ITEMS	1911	ACUSIS
1910	ITEMS	1911	ACUSIS	1912	REPORTS
1911	ACUSIS	1912	REPORTS	1913	FIRST
1912	REPORTS	1913	FIRST	1914	SECOND
1913	FIRST	1914	SECOND	1915	THIRD
1914	SECOND	1915	THIRD	1916	FOURTH
1915	THIRD	1916	FOURTH	1917	FIFTH
1916	FOURTH	1917	FIFTH	1918	SIXTH
1917	FIFTH	1918	SIXTH	1919	SEVENTH
1918	SIXTH	1919	SEVENTH	1920	EIGHTH
1919	SEVENTH	1920	EIGHTH	1921	NINTH
1920	EIGHTH	1921	NINTH	1922	TENTH
1921	NINTH	1922	TENTH	1923	HOLLAN
1922	TENTH	1900	HOLLAN	1901	WRIGHT

 

[B___P]

HI cricketjdw,
give this code a go

Sub SortSideBySideColums()
    'B___P
    'Data area must be a range bounded by any combination of blank rows and blank columns
    'select a cell inside this region and run macro
    Dim BiColumns       As Long
    Dim MyARR           As Variant
    Dim RangeToSort     As Range
    Dim MyRows          As Long
    Dim index           As Long
    Dim ULCorner        As String
    Dim ULCorner2       As String
    Dim Cella           As Range
    
    Set RangeToSort = ActiveCell.CurrentRegion 'with headers
    MyRows = RangeToSort.Rows.Count
    Set RangeToSort = RangeToSort.Offset(1).Resize(MyRows - 1) 'without headers
    
    BiColumns = RangeToSort.Columns.Count / 2
    MyRows = RangeToSort.Rows.Count
    ULCorner = Mid(RangeToSort.Address, 1, (InStr(1, RangeToSort.Address, ":")) - 1)
    ReDim MyArray(1 To BiColumns * MyRows, 1 To 2)
    
    For Each Cella In RangeToSort
        If IsNumeric(Cella) Then
            index = index + 1
            MyArray(index, 1) = Cella
            MyArray(index, 2) = Cella.Offset(0, 1)
        End If
    Next Cella
    
    Call Ordina2ColsArray(MyArray)
    Application.ScreenUpdating = False
    
    For index = LBound(MyArray) To UBound(MyArray)
        Range(ULCorner).Offset(Int((index - 1) / BiColumns), 2 * ((index - 1) Mod BiColumns)) = MyArray(index, 1)
        Range(ULCorner).Offset(0, 1).Offset(Int((index - 1) / BiColumns), 2 * ((index - 1) Mod BiColumns)) = MyArray(index, 2)
    Next index
    
    Application.ScreenUpdating = True
End Sub

Sub Ordina2ColsArray(inArray As Variant)
    Dim x       As Long
    Dim y       As Long
    Dim temp1   As Variant
    Dim temp2   As Variant
    
    For x = LBound(inArray) To UBound(inArray) - 1
        For y = x + 1 To UBound(inArray)
            If inArray(x, 1) > inArray(y, 1) Then
                temp1 = inArray(x, 1): temp2 = inArray(x, 2)
                inArray(x, 1) = inArray(y, 1): inArray(x, 2) = inArray(y, 2)
                inArray(y, 1) = temp1: inArray(y, 2) = temp2
            End If
        Next
    Next
End Sub

Hope this helps.
Have a nice day