Horizontal sort of paired entries - sorting

Question

My VBA skills are basic. I would appreciate help with sorting numbers in a row but with moving their corresponding strings. For example, these rows:
╔═══════╦═════════╦═══════╦═════════╗
║ Name1 ║ Number1 ║ Name2 ║ Number2 ║
╠═══════╬═════════╬═══════╬═════════╣
║ Joe ║ 5 ║ John ║ 10 ║
╚═══════╩═════════╩═══════╩═════════╝
should become:
╔═══════╦═════════╦═══════╦═════════╗
║ Name1 ║ Number1 ║ Name2 ║ Number2 ║
╠═══════╬═════════╬═══════╬═════════╣
║ John ║ 10 ║ Joe ║ 5 ║
╚═══════╩═════════╩═══════╩═════════╝
The code I am trying to adjust is:
Sub hsort()
Dim lLast As Long, lLoop As Long
lLast = Cells(Rows.Count, 1).End(xlUp).Row
For lLoop = 2 To lLast
range(cells(lLoop,4),cells(lLoop,23)).Sort key1:=Cells(lLoop, 5), order1:=xlDescending,key2:=Cells(lLoop, 4), order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Next
End Sub
which orders the strings first and then the numbers, rather than moving them together as wished.

Answer 1

This is very easy with a dictionary, but as #pnuts pointed out, it's a bit advanced. What we're going to do here is to invoke a dictionary, store your data there, transfer them to an array, bubble sort them in descending order, put them back into the dictionary, and print them out.
Whew. Anyway, credits to this site for the framework.
Anyway, code first.
'http://www.xl-central.com/sort-a-dictionary-by-item.html
Sub SortDictionaryByItem()
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim Dict As Scripting.Dictionary
Dim Arr() As Variant
Dim Temp1 As Variant
Dim Temp2 As Variant
Dim Txt As String
Dim i As Long
Dim j As Long
Dim LastCol As Long, Iter As Long, Iter2 As Long, Iter3 As Long
'Create an instance of the Dictionary
Set Dict = New Dictionary
'Set the comparison mode to perform a textual comparison
Dict.CompareMode = TextCompare
'''''''''''''''''BK201's Mod'''''''''''''''''
'Get the last column of the row.
LastCol = Range("A1").End(xlToRight).Column 'Modify accordingly.
'Add keys and items to the Dictionary
For Iter = 1 To (LastCol - 1) Step 2
Dict.Add Cells(1, Iter).Value, Cells(1, Iter + 1).Value
Next Iter
'''''''''''''''''BK201's Mod'''''''''''''''''
'Allocate storage space for the dynamic array
ReDim Arr(0 To Dict.Count - 1, 0 To 1)
'Fill the array with the keys and items from the Dictionary
For i = 0 To Dict.Count - 1
Arr(i, 0) = Dict.Keys(i)
Arr(i, 1) = Dict.Items(i)
Next i
'Sort the array using the bubble sort method
For i = LBound(Arr, 1) To UBound(Arr, 1) - 1
For j = i + 1 To UBound(Arr, 1)
If Arr(i, 1) < Arr(j, 1) Then
Temp1 = Arr(j, 0)
Temp2 = Arr(j, 1)
Arr(j, 0) = Arr(i, 0)
Arr(j, 1) = Arr(i, 1)
Arr(i, 0) = Temp1
Arr(i, 1) = Temp2
End If
Next j
Next i
'Clear the Dictionary
Dict.RemoveAll
'Add the sorted keys and items from the array back to the Dictionary
For i = LBound(Arr, 1) To UBound(Arr, 1)
Dict.Add Key:=Arr(i, 0), Item:=Arr(i, 1)
Next i
'''''''''''''''''BK201's Mod'''''''''''''''''
'Change Cells(2, Iter2) to Cells(1, Iter2) to overwrite.
KeyIndex = 0
For Iter2 = 1 To (LastCol - 1) Step 2
Cells(2, Iter2).Value = Dict.Keys(KeyIndex)
KeyIndex = KeyIndex + 1
Next Iter2
For Iter3 = 2 To LastCol Step 2
Cells(2, Iter3).Value = Dict.Item(Cells(2, Iter3 - 1).Value)
Next Iter3
'''''''''''''''''BK201's Mod'''''''''''''''''
Set Dict = Nothing
End Sub
Screenshots:
Set-up:
Result after running code:
Modify the ranges involved accordingly. Let us know if this helps.

Answer 2

Assuming Name1 is in A1, if you add temporarily a row between Name1 and John with =IF(ISEVEN(COLUMN()),A3,B3) in it copied across to suit you should then achieve the order I think you want with a normal left to right sort and the temporary row can then be deleted. Build this in to VBA if you wish.

Answer 3

At the end this is the solution I adopted but is really Really slow! Does anyone have any suggestion to improve this code? Dictionary seemed to me a good solution but I don't know how to use it so I ask you if it is implementable in this situation.
Sub Reorder()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim i, c, j As Integer
i = 7
Do
j = 5
Do
Workbooks("Ownership Full v3.xlsx").Activate
Range(Cells(i, j), Cells(i, j + 1)).Copy
Workbooks("Book1.xlsx").Activate
If Range("A2") = blank Then
Range("A2").Select
Else
Range("A1").End(xlDown).Select
Selection.Offset(1, 0).Select
End If
ActiveSheet.Paste
j = j + 2
Workbooks("Ownership Full v3.xlsx").Activate
Loop While (j <= 23)
Workbooks("Book1.xlsx").Activate
Range("B2:B11").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:B11")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
j = 5
c = 2
Do
Workbooks("Book1.xlsx").Activate
Range(Cells(c, 1), Cells(c, 2)).Cut
Workbooks("Ownership Full v3.xlsx").Activate
Cells(i, j).Select
ActiveSheet.Paste
c = c + 1
j = j + 2
Loop While (c <= 11)
i = i + 1
Loop While (Cells(i, 1) <> blank)
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub