Excel VBA Collection - sort

Sub test1()
    Dim myList As New Collection
    Dim myCell, myColl, myObject, myItem
    Dim myKey As String
    For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItem = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
                myItem.Add Item:=myObject
            Next myObject
            On Error Resume Next
            myList.Add Item:=myItem, Key:=myKey
            If Err.Number = 457 Then
                On Error GoTo 0
                myList(myKey).Add Item:=myItem
            End If
        End If
    Next myCell
    For Each myColl In myList
        Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
    Next myColl
    Range("D1").Resize(, 3) = Array("Table", "Name", "Seats")
End Sub

Sub test2()
    Dim myList As New Collection
    Dim myCell, myArray, myObject, Swap1, Swap2
    Dim myKey As String, i As Long, j As Long, s As Long
    For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            myArray = Array(myCell.Value, myCell.Offset(0, 1).Value, 1)
            On Error Resume Next
            myList.Add Item:=myArray, Key:=myKey
            If Err.Number = 457 Then
                On Error GoTo 0
                myObject = myList.Item(myKey)
                myObject(2) = myObject(2) + 1
                myList.Remove myKey
                myList.Add Item:=Array(myObject(0), myObject(1), myObject(2)), Key:=myKey
            End If
        End If
    Next myCell
    For s = 0 To 2
        For i = 1 To myList.Count - 1
            For j = i + 1 To myList.Count
                If myList(i)(s) > myList(j)(s) Then
                    Swap1 = myList(i)
                    Swap2 = myList(j)
                    myList.Add Swap1, Before:=j
                    myList.Add Swap2, Before:=i
                    myList.Remove i + 1
                    myList.Remove j + 1
                End If
            Next j
        Next i
        Range(Choose(s + 1, "H", "L", "P") & "1").Resize(, 3) = Array("Table", "Name", "Seats")
        For Each myArray In myList
            Cells(Rows.Count, Choose(s + 1, "H", "L", "P")).End(xlUp).Offset(1, 0).Resize(, 3) = myArray
        Next myArray
    Next s
End Sub

Sub test3()
    Dim myList As New Collection
    Dim myCell, myColl, myObject, Swap1, Swap2
    Dim myKey As String, i As Long, j As Long, s As Long
    Dim myItem, myCount
    For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItem = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
                myItem.Add Item:=myObject
            Next myObject
            On Error Resume Next
            myList.Add Item:=myItem, Key:=myKey
            If Err.Number = 457 Then
                On Error GoTo 0
                myList(myKey).Add Item:=myItem
            End If
        End If
    Next myCell
    For s = 1 To 2
        For i = 1 To myList.Count - 1
            For j = i + 1 To myList.Count
                If myList(i)(s) > myList(j)(s) Then
                    Set Swap1 = myList(i)
                    Set Swap2 = myList(j)
                    myList.Add Swap1, Before:=j
                    myList.Add Swap2, Before:=i
                    myList.Remove i + 1
                    myList.Remove j + 1
                End If
            Next j
        Next i
        Range(Choose(s, "H", "L", "P") & "1").Resize(, 3) = Array("Table", "Name", "Seats")
        For Each myColl In myList
            Cells(Rows.Count, Choose(s, "H", "L", "P")).End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
        Next myColl
    Next s
    For i = 1 To myList.Count - 1
        For j = i + 1 To myList.Count
            If myList(i).Count > myList(j).Count Then
                Set Swap1 = myList(i)
                Set Swap2 = myList(j)
                myList.Add Swap1, Before:=j
                myList.Add Swap2, Before:=i
                myList.Remove i + 1
                myList.Remove j + 1
            End If
        Next j
    Next i
    Range("P1").Resize(, 3) = Array("Table", "Name", "Seats")
    For Each myColl In myList
        Cells(Rows.Count, "P").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
    Next myColl
End Sub

Sub test4()
    Dim myList As New Collection
    Dim myCell, myColl, myObject, Swap1, Swap2
    Dim myKey As String, i As Long, j As Long, s As Long
    Dim myItem, myError, myCount, myIndex, myRemove
    For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItem = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
                myItem.Add Item:=myObject
            Next myObject
            On Error Resume Next
            myError = myList.Item(myKey)
            Debug.Print Err.Number
            If Err.Number = 5 Then
                Err.Clear
                myList.Add Item:=myItem, Key:=myKey
            Else
                Err.Clear
                myList(myKey).Add Item:=myItem
            End If
        End If
    Next myCell
    For s = 1 To 2
        For i = 1 To myList.Count - 1
            For j = i + 1 To myList.Count
                If myList(i)(s) > myList(j)(s) Then
                    Set Swap1 = myList(i)
                    Set Swap2 = myList(j)
                    myList.Add Swap1, Before:=j
                    myList.Add Swap2, Before:=i
                    myList.Remove i + 1
                    myList.Remove j + 1
                End If
            Next j
        Next i
        Range(Choose(s, "H", "L") & "1").Resize(, 3) = Array("Table", "Name", "Seats")
        For Each myColl In myList
            Cells(Rows.Count, Choose(s, "H", "L")).End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
        Next myColl
    Next s
    For i = 1 To myList.Count - 1
        For j = i + 1 To myList.Count
            If myList(i).Count > myList(j).Count Then
                Set Swap1 = myList(i)
                Set Swap2 = myList(j)
                myList.Add Swap1, Before:=j
                myList.Add Swap2, Before:=i
                myList.Remove i + 1
                myList.Remove j + 1
            End If
        Next j
    Next i
    Range("P1").Resize(, 3) = Array("Table", "Name", "Seats")
    For Each myColl In myList
        Cells(Rows.Count, "P").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
    Next myColl
End Sub

Sub test5()
    Dim myList As New Collection
    Dim myCell, myColl, myObject, myMatch
    Dim myKey As String, i As Long, j As Long
    Dim myItem, myError
    For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItem = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
                myItem.Add item:=myObject
            Next myObject
            On Error Resume Next
            myError = myList.item(myKey)
            If Err.Number = 5 Then
                Err.Clear
                myList.Add item:=myItem, Key:=myKey
            Else
                Err.Clear
                myList(myKey).Add item:=myItem
            End If
        End If
    Next myCell
    For Each myColl In myList
        For Each myMatch In myColl
            Cells(1, 3 + i).Resize(, 3) = Array("Table", "Name", "Seats")
            Cells(Rows.Count, 3 + i).End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
        Next myMatch
        i = i + 3
    Next myColl
End Sub