View Full Version : Just testing. Testing some sort routines. No reply needed
DocAElstein
02-17-2019, 04:11 PM
Just testing
test HHKJHDHJHDJAHDKJHD
TEST BLAH
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ- (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8 (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8)
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I (https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)
DocAElstein
02-17-2019, 11:04 PM
Option Explicit
'
' Simplist Sort
Sub SimpleSort()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B6")
' alternative:
Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========================================Outer Loop=====================================
For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------------------------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current rOuter. By the this and all next rOuter, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next rOuter.
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let Temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ================================================== =========================================
Rem 2 Output for easy of demo
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub
' Approximate equivalent to the above routune, using VBA Range.Sort Method ' https://docs.microsoft.com/de-de/office/vba/api/excel.range.sort
Sub Range_Sort()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B6")
' alternative:
Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Rem 1 For demo purposes we will sort a copy of the range
RngToSort.Copy Destination:=RngToSort.Offset(0, RngToSort.Columns.Count)
Dim RngCopy As range: Set RngCopy = RngToSort.Offset(0, RngToSort.Columns.Count)
RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlAscending, MatchCase:=False
Rem 2 Output for easy of demo
Let RngCopy.Interior.Color = vbYellow
End Sub
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg)
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg (https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
DocAElstein
03-10-2019, 09:23 PM
Sub ReorgBy3Criteria()
Rem 0 error handling
On Error GoTo TheEnd:
Rem 1 worksheet info
Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & DieseArbeitsmappe1.ProWb.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet: Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99
Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
Rem 3 VBA Range.Sort Method
' xlDescending Biggest at Top H Kcal J Fett L eiweiss
'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat
'Standard unter ---- Kcal Highest H ,at Top , second most J Fett , highest at Top , third Natrium X , most at top
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
Let Application.EnableEvents = True
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let rngToSort.Value2 = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub 'ReorgBy3Criteria
'
DocAElstein
03-11-2019, 02:27 AM
Routines used to get results of next few post.
Option Explicit
Sub ReorgBy3Criteria()
Rem 0 error handling
On Error GoTo TheEnd:
Rem 1 worksheet info
' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99
Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
Rem 3 VBA Range.Sort Method
' xlDescending Biggest at Top H Kcal J Fett L eiweiss
'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat
'Standard unter ---- Kcal Highest H ,at Top , second most J Fett , highest at Top , third Natrium X , most at top
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
Let Application.EnableEvents = True
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let rngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub 'ReorgBy3Criteria
'
Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
'Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible
Do
' Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26
' Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ?
' 'OR
Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL
Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1) will do in the formula
Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
' https://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213887
'
' Calling code for the main Array sort routine
Sub CallArraySort()
Rem 0 error handling
On Error GoTo TheEnd:
Rem 1 worksheet info
' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3488 ' 3482 '454 '99
Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
Rem 3 Array sort routine alternative coding
'3a) arguments for Called routine
Dim cnt As Long, strIndcs As String: Let strIndcs = " "
For cnt = 1 To rngToSort.Rows.Count
Let strIndcs = strIndcs & cnt & " "
Next cnt
Debug.Print strIndcs
Dim arrTS() As Variant ' : Let arrTS() = ArrrngOrig() ' '3c) alternative
'3b) Do sort
' Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc ") ' '3c) alternative
' Let rngToSort.Value = arrTS() ' '3c) alternative
'3c)
arrTS() = rngToSort.Value: Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): rngToSort.Value = arrTS()
Let Application.EnableEvents = True
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let rngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub
DocAElstein
03-11-2019, 02:34 AM
_____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
16691
118
0.2
7.8
3.1
3.1
34
0.1
16692
123
0.2
7
8.7
8.5
30
0.1
0
16693
120
0.2
7.4
5.7
5.7
32
0
0.1
16694
123
0.2
7
8.9
8.9
30
0.1
16695
118
0.2
7.8
3.1
3.1
34
0
0
0.1
16696
123
0.2
7
8.9
8.9
30
0.1
16697
123
0.2
7
8.9
8.9
30
0.1
16698
119
0.2
7.5
5.1
5.1
33
0
0.1
16699
123
0.2
7
8.9
8.9
30
0.1
16700
123
0.2
7
8.9
8.9
30
0.1
0
0
16701
123
0.2
7
8.9
8.9
30
0.1
16702
123
0.2
7
8.9
8.9
30
0.1
16703
123
0.2
7
8.9
8.9
30
0.1
16704
117
0.2
7.7
3.1
3.1
34
0.1
16705
123
0.2
7
8.9
8.9
30
0.1
16706
117
0.2
7.8
3.1
3.1
34
0.1
16707
117
0.2
7.7
3.1
3.1
34
0.1
16708
120
0.2
6.9
8.4
8.4
30
0.1
0
0
16709
321
17
19
10
1.8
24
0
0.3
16710
121
0.2
6.9
8.8
8.8
30
0.1
16711
300
6.8
29
16
8.7
17
0
0.3
0.1
16712
233
7.3
15
13
5.2
16
0.1
0
16713
186
0.8
19
12
11
28
0.1
0.2
0.1
Worksheet: Sheet1
DocAElstein
03-11-2019, 02:36 AM
Results from Sub ReorgBy3Criteria()
_____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
16691
321
17
19
10
1.8
24
0
0.3
16692
300
6.8
29
16
8.7
17
0
0.3
0.1
16693
233
7.3
15
13
5.2
16
0.1
0
16694
186
0.8
19
12
11
28
0.1
0.2
0.1
16695
123
0.2
7
8.7
8.5
30
0.1
0
16696
123
0.2
7
8.9
8.9
30
0.1
16697
123
0.2
7
8.9
8.9
30
0.1
16698
123
0.2
7
8.9
8.9
30
0.1
16699
123
0.2
7
8.9
8.9
30
0.1
16700
123
0.2
7
8.9
8.9
30
0.1
16701
123
0.2
7
8.9
8.9
30
0.1
16702
123
0.2
7
8.9
8.9
30
0.1
0
0
16703
123
0.2
7
8.9
8.9
30
0.1
16704
123
0.2
7
8.9
8.9
30
0.1
16705
121
0.2
6.9
8.8
8.8
30
0.1
16706
120
0.2
6.9
8.4
8.4
30
0.1
0
0
16707
120
0.2
7.4
5.7
5.7
32
0
0.1
16708
119
0.2
7.5
5.1
5.1
33
0
0.1
16709
118
0.2
7.8
3.1
3.1
34
0
0
0.1
16710
118
0.2
7.8
3.1
3.1
34
0.1
16711
117
0.2
7.8
3.1
3.1
34
0.1
16712
117
0.2
7.7
3.1
3.1
34
0.1
16713
117
0.2
7.7
3.1
3.1
34
0.1
Worksheet: Sheet1
Time .11secs
DocAElstein
03-11-2019, 02:40 AM
Results from Sub CallArraySort()
_____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X
16691
321
17
19
10
1.8
24
0
0.3
16692
300
6.8
29
16
8.7
17
0
0.3
0.1
16693
233
7.3
15
13
5.2
16
0.1
0
16694
186
0.8
19
12
11
28
0.1
0.2
0.1
16695
123
0.2
7
8.7
8.5
30
0.1
0
16696
123
0.2
7
8.9
8.9
30
0.1
16697
123
0.2
7
8.9
8.9
30
0.1
16698
123
0.2
7
8.9
8.9
30
0.1
16699
123
0.2
7
8.9
8.9
30
0.1
16700
123
0.2
7
8.9
8.9
30
0.1
16701
123
0.2
7
8.9
8.9
30
0.1
16702
123
0.2
7
8.9
8.9
30
0.1
0
0
16703
123
0.2
7
8.9
8.9
30
0.1
16704
123
0.2
7
8.9
8.9
30
0.1
16705
121
0.2
6.9
8.8
8.8
30
0.1
16706
120
0.2
6.9
8.4
8.4
30
0.1
0
0
16707
120
0.2
7.4
5.7
5.7
32
0
0.1
16708
119
0.2
7.5
5.1
5.1
33
0
0.1
16709
118
0.2
7.8
3.1
3.1
34
0
0
0.1
16710
118
0.2
7.8
3.1
3.1
34
0.1
16711
117
0.2
7.8
3.1
3.1
34
0.1
16712
117
0.2
7.7
3.1
3.1
34
0.1
16713
117
0.2
7.7
3.1
3.1
34
0.1
Worksheet: Sheet1
Time .7 secs
DocAElstein
03-11-2019, 12:02 PM
The two codes are simply modified to give a time measurement thus:
Range.Sort Method:
Dim StartTime As Double: Let StartTime = Timer
rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
MsgBox prompt:=Round(Timer - StartTime, 2)
Array Sort coding ( In recursion code): ( Sub SimpleArraySort6( )
'3c)
Dim StartTime As Double: Let StartTime = Timer
arrTS() = rngToSort.Value: Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): rngToSort.Value = arrTS()
MsgBox prompt:=Round(Timer - StartTime, 2)
Part of original data test range
_____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
W
X
Y
824
338
0.1
0
825
826
351
0.1
827
342
0.1
0
828
342
0
829
341
0.1
0
830
338
1
0
831
338
0.1
0
832
338
0.1
0.1
833
337
0.5
0.1
834
337
0.1
0
835
337
0
0.1
836
336
0.2
0
837
335
0.1
0
838
334
0
0.1
839
333
0.2
0
840
332
0.2
0
841
332
0.1
0.1
842
332
0.1
0
843
331
0.1
0.1
844
331
0.1
0.1
845
329
0.2
0
846
329
0.1
0
847
326
0.3
0
848
326
0.3
0
849
326
0.2
0
850
326
0.1
0
851
324
0.1
0.1
852
324
0.1
0
853
319
0.2
0.1
854
318
0.5
0.1
855
316
0.2
0.1
856
279
0.5
0.1
857
232
0.1
0
858
230
0.2
0
859
215
0
0
860
861
338
0.1
0.1
862
339
0.1
0
863
337
0.1
0.1
864
865
338
1
0
Worksheet: Sheet1
"ProAktuellex8600x2SortTime.xlsm" https://app.box.com/s/af7891hzmd3sbfnnsmx5b28ktec6wwjo
DocAElstein
03-11-2019, 09:43 PM
Range.Sort
_____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
W
X
Y
824
351
0.1
825
342
0.1
0
826
342
0
827
341
0.1
0
828
339
0.1
0
829
338
1
0
830
338
1
0
831
338
0.1
0.1
832
338
0.1
0.1
833
338
0.1
0
834
338
0.1
0
835
337
0.5
0.1
836
337
0.1
0.1
837
337
0.1
0
838
337
0
0.1
839
336
0.2
0
840
335
0.1
0
841
334
0
0.1
842
333
0.2
0
843
332
0.2
0
844
332
0.1
0.1
845
332
0.1
0
846
331
0.1
0.1
847
331
0.1
0.1
848
329
0.2
0
849
329
0.1
0
850
326
0.3
0
851
326
0.3
0
852
326
0.2
0
853
326
0.1
0
854
324
0.1
0.1
855
324
0.1
0
856
319
0.2
0.1
857
318
0.5
0.1
858
316
0.2
0.1
859
279
0.5
0.1
860
232
0.1
0
861
230
0.2
0
862
215
0
0
Worksheet: Sheet1
Time .25secs
DocAElstein
03-11-2019, 09:56 PM
Array Sort
_____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
W
X
824
351
0.1
825
342
0.1
0
826
342
0
827
341
0.1
0
828
339
0.1
0
829
338
1
0
830
338
1
0
831
338
0.1
0.1
832
338
0.1
0.1
833
338
0.1
0
834
338
0.1
0
835
337
0.5
0.1
836
337
0.1
0.1
837
337
0.1
0
838
337
0
0.1
839
336
0.2
0
840
335
0.1
0
841
334
0
0.1
842
333
0.2
0
843
332
0.2
0
844
332
0.1
0.1
845
332
0.1
0
846
331
0.1
0.1
847
331
0.1
0.1
848
329
0.2
0
849
329
0.1
0
850
326
0.3
0
851
326
0.3
0
852
326
0.2
0
853
326
0.1
0
854
324
0.1
0.1
855
324
0.1
0
856
319
0.2
0.1
857
318
0.5
0.1
858
316
0.2
0.1
859
279
0.5
0.1
860
232
0.1
0
861
230
0.2
0
862
215
0
0
Worksheet: Sheet1
Time 1.25secs
Immediate Window output
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
First procedure Call
Running Copy 1 of routine.
Sorted rows 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 based on values in column 8
Checking now for Dups in that last sorted list
Found dups in last list column 8, 2 3 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 2 3 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 8, 6 7 8 9 10 11 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 6 7 8 9 10 11 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 10, 6 7 , so now Rec Call 1
Running Copy 3 of routine.
Sorted rows 6 7 based on values in column 24
Checking now for Dups in that last sorted list
Found dups in last list column 8, 12 13 14 15 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 12 13 14 15 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 10, 13 14 , so now Rec Call 1
Running Copy 3 of routine.
Sorted rows 13 14 based on values in column 24
Checking now for Dups in that last sorted list
Found dups in last list column 8, 20 21 22 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 20 21 22 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 8, 23 24 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 23 24 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 8, 25 26 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 25 26 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 8, 27 28 29 30 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 27 28 29 30 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list column 10, 27 28 , so now Rec Call 1
Running Copy 3 of routine.
Sorted rows 27 28 based on values in column 24
Checking now for Dups in that last sorted list
Found dups in last list column 8, 31 32 , so now Rec Call 1
Running Copy 2 of routine.
Sorted rows 31 32 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list, so now Rec Call 2 (Dups at list end case)
Running Copy 2 of routine.
Sorted rows 40 41 42 based on values in column 10
Checking now for Dups in that last sorted list
Found dups in last list, so now Rec Call 2 (Dups at list end case)
Running Copy 3 of routine.
Sorted rows 40 41 42 based on values in column 24
Checking now for Dups in that last sorted list
Found dups in last list, so now Rec Call 2 (Dups at list end case)
You need more than 3 keys to complete sort
See further tests from here
http://www.excelfox.com/forum/showthread.php/2306-Just-testing-Testing-some-sort-routines-No-reply-needed?p=11055&viewfull=1#post11055
DocAElstein
03-13-2019, 02:44 PM
In support of this Thread
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use
Posts from approx
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11047&viewfull=1#post11047
Initial test range
_____ ( Using Excel 2007 32 bit )
Row\Col
P
Q
R
S
T
U
V
W
21
22
1
2
3
4
5
6
23
1CrispsWas S23
500Was U23
0.7Was W23
24
2Beer Was S24
200Was U24
0.1Was W24
25
3WineWas S25
150Was U25
0.15Was W25
26
4BeerWas S26
200Was U26
0.07Was W26
27
5beerWas S27
220Was U27
0.2Was W27
28
6BeerWas S28
210Was U28
0.06Was W28
29
7WineWas S29
160Was U29
0.04Was W29
30
8wiNeWas S30
150Was U30
0.03Was W30
31
9CrispsWas S31
502Was U31
2Was W31
32
10Onion RingesWas S32
480Was U32
1Was W32
33
11Onion RingesWas S33
490Was U33
1.5Was W33
34
12CrispsWas S34
502Was U34
1.5Was W34
35
13CRISPSWas S35
500Was U35
1.1Was W35
36
14WineWas S36
170Was U36
0.1Was W36
37
15CrispsWas S37
500Was U37
3Was W37
Worksheet: Sorting
DocAElstein
03-13-2019, 02:47 PM
In support of this Thread
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use
Posts from approx
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11047&viewfull=1#post11047
Results up to just after first run of this section ( based on the initial unsorted test data range in last post )
' Captains Blog, Start Treck
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Clear
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Value = arsRef()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Clear
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Value = arrIndx()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Clear
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
Debug.Print " Running Copy " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
The second two ranges are produced form that ' Captains Blog, Start Treck. ( The first range is produced in the Calling routines, and tests the arrOut() = App.Indx( arrOrig() , {1;2;3;4 .....} , {1,2,3,4,5 ......} )
idea to reproduce the initial test range )
_____ ( Using Excel 2007 32 bit )
Row\Col
P
Q
R
S
T
U
V
W
X
Y
Z
AA
AB
AC
AD
38
1CrispsWas S23
500Was U23
0.7Was W23
39
2Beer Was S24
200Was U24
0.1Was W24
40
3WineWas S25
150Was U25
0.15Was W25
41
4BeerWas S26
200Was U26
0.07Was W26
42
5beerWas S27
220Was U27
0.2Was W27
43
6BeerWas S28
210Was U28
0.06Was W28
44
7WineWas S29
160Was U29
0.04Was W29
45
8wiNeWas S30
150Was U30
0.03Was W30
46
9CrispsWas S31
502Was U31
2Was W31
47
10Onion RingesWas S32
480Was U32
1Was W32
48
11Onion RingesWas S33
490Was U33
1.5Was W33
49
12CrispsWas S34
502Was U34
1.5Was W34
50
13CRISPSWas S35
500Was U35
1.1Was W35
51
14WineWas S36
170Was U36
0.1Was W36
52
15CrispsWas S37
500Was U37
3Was W37
53
3WineWas S25
150Was U25
0.15Was W25WineWas S25
150Was U25
0.15Was W25
54
7WineWas S29
160Was U29
0.04Was W29WineWas S29
160Was U29
0.04Was W29
55
8wiNeWas S30
150Was U30
0.03Was W30wiNeWas S30
150Was U30
0.03Was W30
56
14WineWas S36
170Was U36
0.1Was W36WineWas S36
170Was U36
0.1Was W36
57
11Onion RingesWas S33
490Was U33
1.5Was W33Onion RingesWas S33
490Was U33
1.5Was W33
58
10Onion RingesWas S32
480Was U32
1Was W32Onion RingesWas S32
480Was U32
1Was W32
59
9CrispsWas S31
502Was U31
2Was W31CrispsWas S31
502Was U31
2Was W31
60
12CrispsWas S34
502Was U34
1.5Was W34CrispsWas S34
502Was U34
1.5Was W34
61
13CRISPSWas S35
500Was U35
1.1Was W35CRISPSWas S35
500Was U35
1.1Was W35
62
1CrispsWas S23
500Was U23
0.7Was W23CrispsWas S23
500Was U23
0.7Was W23
63
15CrispsWas S37
500Was U37
3Was W37CrispsWas S37
500Was U37
3Was W37
64
2Beer Was S24
200Was U24
0.1Was W24Beer Was S24
200Was U24
0.1Was W24
65
4BeerWas S26
200Was U26
0.07Was W26BeerWas S26
200Was U26
0.07Was W26
66
5beerWas S27
220Was U27
0.2Was W27beerWas S27
220Was U27
0.2Was W27
67
6BeerWas S28
210Was U28
0.06Was W28BeerWas S28
210Was U28
0.06Was W28
68
Worksheet: Sorting
Second range left comes from arsRef() ___Range to right comes from arrIndx() = Application.Index(arrOrig(), Rs(), Cms())
DocAElstein
03-13-2019, 05:04 PM
Full run results ( For recursion routine )
_____ ( Using Excel 2007 32 bit )
3WineWas S25
150Was U25
0.15Was W25WineWas S25
150Was U25
0.15Was W25
7WineWas S29
160Was U29
0.04Was W29WineWas S29
160Was U29
0.04Was W29
8wiNeWas S30
150Was U30
0.03Was W30wiNeWas S30
150Was U30
0.03Was W30
14WineWas S36
170Was U36
0.1Was W36WineWas S36
170Was U36
0.1Was W36
11Onion RingesWas S33
490Was U33
1.5Was W33Onion RingesWas S33
490Was U33
1.5Was W33
10Onion RingesWas S32
480Was U32
1Was W32Onion RingesWas S32
480Was U32
1Was W32
9CrispsWas S31
502Was U31
2Was W31CrispsWas S31
502Was U31
2Was W31
12CrispsWas S34
502Was U34
1.5Was W34CrispsWas S34
502Was U34
1.5Was W34
13CRISPSWas S35
500Was U35
1.1Was W35CRISPSWas S35
500Was U35
1.1Was W35
1CrispsWas S23
500Was U23
0.7Was W23CrispsWas S23
500Was U23
0.7Was W23
15CrispsWas S37
500Was U37
3Was W37CrispsWas S37
500Was U37
3Was W37
2Beer Was S24
200Was U24
0.1Was W24Beer Was S24
200Was U24
0.1Was W24
4BeerWas S26
200Was U26
0.07Was W26BeerWas S26
200Was U26
0.07Was W26
5beerWas S27
220Was U27
0.2Was W27beerWas S27
220Was U27
0.2Was W27
6BeerWas S28
210Was U28
0.06Was W28BeerWas S28
210Was U28
0.06Was W28
8wiNeWas S30
150Was U30
0.03Was W30wiNeWas S30
150Was U30
0.03Was W30
3WineWas S25
150Was U25
0.15Was W25WineWas S25
150Was U25
0.15Was W25
7WineWas S29
160Was U29
0.04Was W29WineWas S29
160Was U29
0.04Was W29
14WineWas S36
170Was U36
0.1Was W36WineWas S36
170Was U36
0.1Was W36
10Onion RingesWas S32
480Was U32
1Was W32Onion RingesWas S32
480Was U32
1Was W32
11Onion RingesWas S33
490Was U33
1.5Was W33Onion RingesWas S33
490Was U33
1.5Was W33
1CrispsWas S23
500Was U23
0.7Was W23CrispsWas S23
500Was U23
0.7Was W23
13CRISPSWas S35
500Was U35
1.1Was W35CRISPSWas S35
500Was U35
1.1Was W35
15CrispsWas S37
500Was U37
3Was W37CrispsWas S37
500Was U37
3Was W37
12CrispsWas S34
502Was U34
1.5Was W34CrispsWas S34
502Was U34
1.5Was W34
9CrispsWas S31
502Was U31
2Was W31CrispsWas S31
502Was U31
2Was W31
2Beer Was S24
200Was U24
0.1Was W24Beer Was S24
200Was U24
0.1Was W24
4BeerWas S26
200Was U26
0.07Was W26BeerWas S26
200Was U26
0.07Was W26
6BeerWas S28
210Was U28
0.06Was W28BeerWas S28
210Was U28
0.06Was W28
5beerWas S27
220Was U27
0.2Was W27beerWas S27
220Was U27
0.2Was W27
8wiNeWas S30
150Was U30
0.03Was W30wiNeWas S30
150Was U30
0.03Was W30
3WineWas S25
150Was U25
0.15Was W25WineWas S25
150Was U25
0.15Was W25
7WineWas S29
160Was U29
0.04Was W29WineWas S29
160Was U29
0.04Was W29
14WineWas S36
170Was U36
0.1Was W36WineWas S36
170Was U36
0.1Was W36
10Onion RingesWas S32
480Was U32
1Was W32Onion RingesWas S32
480Was U32
1Was W32
11Onion RingesWas S33
490Was U33
1.5Was W33Onion RingesWas S33
490Was U33
1.5Was W33
1CrispsWas S23
500Was U23
0.7Was W23CrispsWas S23
500Was U23
0.7Was W23
13CRISPSWas S35
500Was U35
1.1Was W35CRISPSWas S35
500Was U35
1.1Was W35
15CrispsWas S37
500Was U37
3Was W37CrispsWas S37
500Was U37
3Was W37
12CrispsWas S34
502Was U34
1.5Was W34CrispsWas S34
502Was U34
1.5Was W34
9CrispsWas S31
502Was U31
2Was W31CrispsWas S31
502Was U31
2Was W31
4BeerWas S26
200Was U26
0.07Was W26BeerWas S26
200Was U26
0.07Was W26
2Beer Was S24
200Was U24
0.1Was W24Beer Was S24
200Was U24
0.1Was W24
6BeerWas S28
210Was U28
0.06Was W28BeerWas S28
210Was U28
0.06Was W28
5beerWas S27
220Was U27
0.2Was W27beerWas S27
220Was U27
0.2Was W27
Worksheet: Sorting
DocAElstein
03-14-2019, 03:28 PM
These tests pick up the Thread from about here .._
http://www.excelfox.com/forum/showthread.php/2306-Just-testing-Testing-some-sort-routines-No-reply-needed?p=11043&viewfull=1#post11043
_.. and use the same test range from there ( and in the uploaded file "ProAktuellex8600x2SortTime6_8.xlsm" )
Sub ReorgBy3Criteria()
The test routine for the Range.Sort , Sub ReorgBy3Criteria() , remains the same.
We need some global variables for Sub SimpleArraySort8(
Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies
Dim arrOrig() As Variant
These are important variables used in the = Application.Index(arrOrig(), Rs(), Cms()) code line, which applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range. A global variable is convenient for the constants of arrOrig() and all sequential column indicies, Cms() . Using a global variable for Rs() is a convenient alternative to passing its value through each recursion procedure copy Call
Within all copies of the recursion routine , arrIndx() is the important taken As Referred to array contain the current state of data range being sorted. At each column sort the row indices are sorted in parallel the column elements of only the column currently being sorted by. Then at the end of each sort the entire array, arrIndx() , gets updated through the use of
____ arrIndx() = Application.Index(arrOrig(), Rs(), Cms()).
This removes the need to do the sort on all columns during each sort: Only the column being used to determine the sorted order is re ordered, ( as well as the row indicie list in Rs() ). The remain columns get updated by the above formula
This is the main distinguishing characteristic of the Index idea way.
Sub CallArraySort8()
There is no significant change required here, since the signature line of Sub SimpleArraySort6( is in effect the same as. The only visible difference is the use of the array taken By Refer to , which is arrIndx() rather than arsRef() in Sub SimpleArraySort6( . But these are the variables that effectively “carry” internally the array carrying the current stand of the data range being constantly resorted. We pass to those , so there name to the Calling routine is irrelevant. These determine the name of the passes array as referred to within the respective routine. The only reason why we have different names is because in the intermediate solution, Sub SimpleArraySort7( , both ways were done in parallel for comparison of results, ( in terms of accuracy)
We have just a three things extra to do .
We must fill the two global variables Cms() and Rs()
Cms() needs filling once with a “horizontal” list of all sequential columns as all are referred to in every use of the = Application.Index(arrOrig(), Rs(), Cms()) code line.
The “vertical row” indices, Rs() , initially need filling with the full range row indices in the initial unsorted order
For convenience, both are filled using a spreadsheet function as discussed here http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11051&viewfull=1#post11051
The global variable for the original range of data , arrOrig() , also needs to be filled.
( We note that we could use this in place of the ArrrngOrig() which we have to restore our original range if we do not accept the resorted range. But for consistency with the previous coding we will not change this at this stage )
Coding in next posts
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)
DocAElstein
03-14-2019, 08:45 PM
Global variables , Range.Sort comparison routine , required Function , and Calling routine for recursion routine
( Recursion routine is here : http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11058&viewfull=1#post11058 )
Global variables , Range.Sort comparison routine , required Function
Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies
' Dim RngToSort As Range ' Test data range for Sub SimpleArraySort7()
Dim arrOrig() As Variant ' This arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range
' Dim arrIndx() As Variant ' For Sub SimpleArraySort7()
Sub ReorgBy3Criteria()
Rem 0 error handling
On Error GoTo TheEnd:
Rem 1 worksheet info
' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99
Dim RngToSort As Range: Set RngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = RngToSort.Value ' This is used as a back up to restore the original range
Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
Rem 3 VBA Range.Sort Method
' xlDescending Biggest at Top H Kcal J Fett L eiweiss
'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat
'Standard unter ---- Kcal Highest H ,at Top , second most J Fett , highest at Top , third Natrium X , most at top
Dim StartTime As Double: Let StartTime = Timer
RngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
MsgBox Prompt:=Round(Timer - StartTime, 2)
Let Application.EnableEvents = True
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let RngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub 'ReorgBy3Criteria
'
Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
'Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible
Do
' Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26
' Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ?
' 'OR
Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL
Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1) will do in the formula
Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
Calling routine for recursion routine
' Calling code for the main Array sort routine
Sub CallArraySort8()
Rem 0 error handling
'On Error GoTo TheEnd:
Rem 1 worksheet info
' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3488 ' 3482 '454 '99
Dim RngToSort As Range: Set RngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
Dim ArrrngOrig() As Variant: Let ArrrngOrig() = RngToSort.Value ' This is used as a back up to restore the original range
'Let Application.EnableEvents = False ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
'2b Initial Rs() indicies and required sequential column indicies, Cms(), and original data range arrOrig() - these are global variables
Let Cms() = Evaluate("=Column(" & CL(1) & ":" & CL(RngToSort.Columns.Count) & ")")
Let Rs() = Evaluate("=Row(1:" & RngToSort.Rows.Count & ")")
Let arrOrig() = ArrrngOrig() ' Direct assignment to a dynamic array is possible, we use variant types because the Index returns variant types, and we also needed variant for the range capture using .Value as this also returns variant types. hence we can assign the arrays to eachother as they have similar types
Rem 3 Array sort routine alternative coding
'3a) arguments for Called routine
Dim cnt As Long, strIndcs As String: Let strIndcs = " "
For cnt = 1 To RngToSort.Rows.Count
Let strIndcs = strIndcs & cnt & " "
Next cnt
Debug.Print strIndcs
Dim arrTS() As Variant ' : Let arrTS() = ArrrngOrig() ' '3c) alternative
'3b) Do sort
' Call SimpleArraySort8(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc ") ' '3c) alternative
' Let rngToSort.Value = arrTS() ' '3c) alternative
'3c)
Let Application.EnableEvents = False
Dim StartTime As Double: Let StartTime = Timer
arrTS() = RngToSort.Value: Call SimpleArraySort8(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): RngToSort.Value = arrTS()
MsgBox Prompt:=Round(Timer - StartTime, 2)
Let Application.EnableEvents = True
Rem 4 Msg Box check if all is well, if not put original enties back in. COMMENTED OUT FOR SPEED TESTS
Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
' all is well - carry on after End If
Else
Let Application.EnableEvents = False
Let RngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
Let Application.EnableEvents = True
End If
Exit Sub ' Routine end if no errors____________________________________________ ________________________
TheEnd: ' Error handling code section
Let Application.EnableEvents = True ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a .EnableEvents = False and before a .EnableEvents = True
MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
End Sub
' Recursion routine is here : http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11058&viewfull=1#post11058 )
DocAElstein
03-14-2019, 08:55 PM
Results using coding above and same test range as previous coding
_____ Workbook: ProAktuellex8600x2SortTime6_8.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
W
X
Y
824
351
0.1
825
342
0.1
0
826
342
0
827
341
0.1
0
828
339
0.1
0
829
338
1
0
830
338
1
0
831
338
0.1
0.1
832
338
0.1
0.1
833
338
0.1
0
834
338
0.1
0
835
337
0.5
0.1
836
337
0.1
0.1
837
337
0.1
0
838
337
0
0.1
839
336
0.2
0
840
335
0.1
0
841
334
0
0.1
842
333
0.2
0
843
332
0.2
0
844
332
0.1
0.1
845
332
0.1
0
846
331
0.1
0.1
847
331
0.1
0.1
848
329
0.2
0
849
329
0.1
0
850
326
0.3
0
851
326
0.3
0
852
326
0.2
0
853
326
0.1
0
854
324
0.1
0.1
855
324
0.1
0
856
319
0.2
0.1
857
318
0.5
0.1
858
316
0.2
0.1
859
279
0.5
0.1
860
232
0.1
0
861
230
0.2
0
862
215
0
0
863
864
865
Worksheet: Sheet1
Time
Sub SimpleArraySort8( -- 3.4 secs
Sub ReorgBy3Criteria() ( Range.Sort ) -- .26 secs
Sub SimpleArraySort6( -- 1.2 secs
https://app.box.com/s/34mcb2pe4z9y8hhlb2h87xit4ksuiw9q " ProAktuellex8600x2SortTime6_8.xlsm "
DocAElstein
03-15-2019, 11:23 PM
Intermediate step coding for this post:
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11064&viewfull=1#post11064
( Remember to include at top of module the global variable
Dim Rs() As Variant )
Intermediate routine
'
Sub Call_Sub_Bubbles()
' data range info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant ' array to be referred to in all recursion routines, initially the original data range
Let arrTS() = RngToSort.Value
Let Rs() = Evaluate("=Row(1:6)") ' ' Initial row indicies
Call Bubbles(1, arrTS(), " 1 Asc 3 Asc 2 Asc ")
' Demo output
Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrTS()
End Sub
'
Sub Bubbles(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc…
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
' making an array from the " 3 4 5 6 " string is just for convenience later of getting the upper and lower row numbers
Rem 1 Bubble sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' For first row indicie to last but one row indicie
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ================================================== ========================================
End Sub
DocAElstein
03-17-2019, 04:58 PM
Intermediate step coding for this post:
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11075&viewfull=1#post11075
Sub Call_Sub_BubblesIndexIdeaWay() ' Partially hard coded for ease of explanation
' data range info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant ' This is somewhat redundant for this version and could be replaced by arrOrig()
Let arrTS() = RngToSort.Value
' Index idea variables
Let arrOrig() = arrTS()
Let arrIndx() = arrTS()
Let Cms() = Evaluate("=Column(A:D)") ' Convenient way to get
Let Rs() = Evaluate("=Row(1:6)") ' Initial row indicies
' Add initial indicies
Let RngToSort.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed
Let RngToSort.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed
' Initial row indicies from full original range´of rows
Dim strRows As String, Cnt As Long: Let strRows = " "
For Cnt = 1 To 6
Let strRows = strRows & Rs(Cnt, 1) & " "
Next Cnt
' we should have now strRows = " 1 2 3 4 5 6 "
Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc 2 Asc ")
' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc ")
' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc ")
' Demo output
Dim RngDemoOutput As Range: Set RngDemoOutput = WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count)
' Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrIndx()
Let RngDemoOutput = arrIndx()
Let RngDemoOutput.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed
Let RngDemoOutput.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed
End Sub
'
Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc…
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
Rem 1 Bubble sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1
For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
'For rOuter = 1 To 5 ' For first run
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ================================================== ========================================
Rem 3 Preparation for possible recursion Call
' Catpains Blog
Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below
Let strRws = ""
'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1
For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative
If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces )
' Now its time to organise a recursion run
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If ' we did not have more than one indicie in strRws so usually that's it for this loop
End If
'+++*** this would be end of loop for most cases ... but Oh Fuck
'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Next rOuter ' ************************************************** ************************
Debug.Print "Ending a copy, Copy level " & CopyNo & ""
End Sub
DocAElstein
03-17-2019, 06:10 PM
Final modified coding for this post
http://www.excelfox.com/forum/showthread.php/2307-VBA-Range-Sort-with-arrays-Alternative-for-simple-use?p=11075&viewfull=1#post11075
Sub Call_Sub_BubblesIndexIdeaWay() ' Partially hard coded for ease of explanation
' data range info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16")
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant ' This is somewhat redundant for this version and could be replaced by arrOrig()
Let arrTS() = RngToSort.Value
' Index idea variables
Let arrOrig() = arrTS()
Let arrIndx() = arrTS()
Let Cms() = Evaluate("=Column(A:D)") ' Convenient way to get
Let Rs() = Evaluate("=Row(1:6)") ' Initial row indicies
' Add initial indicies
Let RngToSort.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed
Let RngToSort.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed
' Initial row indicies from full original range´of rows
Dim strRows As String, Cnt As Long: Let strRows = " "
For Cnt = 1 To 6
Let strRows = strRows & Rs(Cnt, 1) & " "
Next Cnt
' we should have now strRows = " 1 2 3 4 5 6 "
Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc 2 Asc ")
' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc ")
' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc ")
' Demo output
Dim RngDemoOutput As Range: Set RngDemoOutput = WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count)
' Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrIndx()
Let RngDemoOutput = arrIndx()
Let RngDemoOutput.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed
Let RngDemoOutput.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed
'
' Let RngDemoOutput.Offset(RngDemoOutput.Rows.Count, 0) = Application.Index(arrOrig(), Rs(), Cms())
End Sub
'
Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String)
Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc…
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it
'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column
Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level
Rem 1 Bubble sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1
For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
'For rOuter = 1 To 5 ' For first run
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest
If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(rInner, Clm)) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arsRef(), 2)
Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Dim TempRs As Long
Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End=Rem 1================================================= ==============
Rem 2
Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms())
Rem 3 Preparation for possible recursion Call
' Catpains Blog
Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf
Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below
Let strRws = ""
'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1
For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121
If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative
If Trim(UCase(CStr(arrIndx(rOuter, Clm)))) = Trim(UCase(CStr(arrIndx(rOuter + 1, Clm)))) Then ' case in duplicate rows
Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line
Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces )
' Now its time to organise a recursion run
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated
Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates
Let strRws = "" ' ready to try for another set of duplicates
Else
End If ' we did not have more than one indicie in strRws so usually that's it for this loop
End If
'+++*** this would be end of loop for most cases ... but Oh Fuck
'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......|
If rOuter = UBound(arrIndx(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row
Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list
Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys)
Else
End If '... .................................................. ..............|
Next rOuter ' ************************************************** ************************
Debug.Print "Ending a copy, Copy level " & CopyNo & ""
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.