Horizontal sort of paired entries

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.

Answers


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.


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.


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

Need Your Help

How to get count of records which have duplicate value in mysql

php mysql

I have a table with player and status, this table not got corrupted and it has duplicate entries like this:

retrieve data using model relationship laravel 4

php model laravel-4 eloquent table-relationships

I'm really confused why I keep getting a null value when retrieving data from my data model.