Sub TestieSimpleArraySort8() ( and Global variables and a required Function )
Global variables required. ( Must go at top of code module )
Code:
Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies
Dim RngToSort As Range ' Test data range
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
A required function
Code:
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
Do
Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL
Let lclm = (lclm - (1)) \ 26
Loop While lclm > 0
End Function
Function FukOutChrWithDoWhile(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 FukOutChrWithDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & FukOutChrWithDoWhile
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
' https://www.excelforum.com/tips-and-tutorials/1213798-all-sub-folder-and-file-list-from-vba-recursion-routine-explanation-and-method-comparison.html
Calling routine ( to call recursion routine in next post )
Code:
Sub TestieSimpleArraySort8()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
' Dim RngToSort As Range
Set RngToSort = WsS.Range("R23:W37")
' 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
Let arrIndx() = arrTS()
Let arrOrig() = arrTS() ' This 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
' Call SimpleArraySort8(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc")
' Column Indicies
Let Cms() = Evaluate("=Column(" & CL(1) & ":" & CL(RngToSort.Columns.Count) & ")")
Let Cms() = Evaluate("=Column(A:F)")
' Initial row indicies
Let Rs() = Evaluate("=Row(1:" & RngToSort.Rows.Count & ")")
' test index
RngToSort.Offset(-1, 0).Resize(1, UBound(Cms())).Value = Cms()
RngToSort.Offset(0, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
RngToSort.Offset(RngToSort.Rows.Count, 0).ClearContents
Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrTS(), Rs(), Cms())
' Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrIndx(), Rs(), Cms())
RngToSort.Offset(RngToSort.Rows.Count, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs()
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 ' For 5 rows , for example we will have " 1 2 3 4 5 " , for 15 rows " 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 "
Call SimpleArraySort8(1, arrTS(), strIndcs, " 1 Desc 3 Asc 5 Asc")
Rem 2 Output for easy of demo
' 2a
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
' 2b VBA Range.Sort Method equivalent
Dim TestRngSrt As Range: Set TestRngSrt = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
TestRngSrt.Clear
Let TestRngSrt.Value = RngToSort.Value
TestRngSrt.Sort Key1:=TestRngSrt.Columns("A:A"), order1:=xlDescending, Key2:=TestRngSrt.Columns("C:C"), order2:=xlAscending, Key3:=TestRngSrt.Columns("E:E"), order3:=xlAscending, MatchCase:=False
TestRngSrt.Interior.Color = vbGreen
End Sub
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=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=UgwNaJiNATXshvJ0Zz94AaABAg. 9iEktVkTAHk9iF9_pdshr6
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg. 9iDVgy6wzct9iFBxma9zXI
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=UgwJ3yzdk_EE98dndmt4AaABAg. 9iDLC2uEPRW9iFGvgk11nH
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg. 9iH3wvUZj3n9iHnpOxOeXa
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg. 9iGReNGzP4v9iHoeaCpTG8
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I
Sub BubblesIndexIdeaWay As Sub Bubble , just replacing name in three places
Code:
'
Sub Bubbles(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
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 Bubbles(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
' ...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 Bubbles(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... ................................................................|
Next rOuter ' **************************************************************************
Debug.Print "Ending a copy, Copy level " & CopyNo & ""
End Sub
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg. 9hI1CQJMLLo9hWn2pGBeSS
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg. 9hJRnEjxQrd9hJoCjomNI2
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg. 9hJOZEEZa6p9hJqLC7El-w
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg. 9hIlxxGY7t49hJsB2PWxC4
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg. 9hIKlNPeqDn9hJskm92np6
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg. 9hI2IGUdmTW9hJuyaQawqx
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg. 9hI1CQJMLLo9hJwTB9Jlob
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
Sub BubblesIndexIdeaWay As Sub Bubble , just replacing name in three places
This intermadiate routine is simply Sub Bubbles(), with the name changed to Sub BubblesIndexIdeaWay(), and the two recursion Calling code lines changed from
Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys)
to
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys)
Code:
'
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
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
Sub Call_Sub_BubblesIndexIdeaWay()
Calling routine required for previous Post and following Post
Code:
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
1 Attachment(s)
Deafault item to use if empty column
In support of answer to this excelfox Thread:
http://www.excelfox.com/forum/showth...ll=1#post11090
Code:
Option Explicit
Sub DefaultItem()
Rem 1 data range info
Dim rngIn As Range, Lr As Long, ClmCnt As Long
Let ClmCnt = 3 ' : Let ClmCnt = Worksheets("Sheet2").Range("A1").CurrentRegion.Columns.Count
Let Lr = Worksheets("Sheet2").Range("A1").CurrentRegion.Rows.Count
Set rngIn = Worksheets("Sheet2").Range("A1:C" & Lr & "")
Rem 2 Data to array
Dim arrDtaIn() As Variant ' I need Variant type as the .Value in the next line returns a field of Variant type elements
Let arrDtaIn() = rngIn.Value
Rem 3 Determine default values
' 3a) Number of groups
Dim arrGp() As Variant: Let arrGp() = Application.Index(rngIn, 0, 1).Value ' http://www.excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%E2%80%93-Application-Index Highlight arrGp and Hit F9.JPG : https://imgur.com/PZF0oXE
Dim strGps As String: Let strGps = " " ' For a string like " 1 2 3 "
Dim cnt As Long
For cnt = 2 To Lr ' looking at all rows from the second in our input data
If InStr(1, strGps, " " & arrGp(cnt, 1) & " ") = 0 Then ' This looks for the positiopn along ( starting from character 1 , in strGps , of each row element arrGp(cnt, 1) ) if it is not found then Instr retourns 0 as a n indication that it was not there
Let strGps = strGps & arrGp(cnt, 1) & " " ' Because it is not there, we now put it in
Else
End If
Next cnt
' At this point we should have like strGps = " 1 2 3 "
' 3b) Array of unique groups
Let strGps = Trim(strGps) ' This takes off the first and last trailing spaces
Dim arrGps() As String ' The string split function below returns a fiels of String elements : Highlight arrGps Hit F9.JPG : https://imgur.com/LT9dgHk
Let arrGps() = Split(strGps, " ", -1, vbBinaryCompare) ' this splits the ( strgps , using " " as denominator , and returns all elemants in an array, using exact binary computer match on the " " )
' 3c) Array for output
Dim arrOut() As String ' A dynamic array is needed as I can only use variables in the ReDim method - I cannot use varable in the declaration (Dim) statement
ReDim arrOut(1 To UBound(arrGps()) + 2, 1 To 2) ' I want +1 rows for the header I also need +1 because split retouns a 1 dimensional array stating at indicie 0 - so the Ubound of arrGps() will give a numbe 1 less than I might expect - in our example we have 3 elements with indicies of 0 1 2, ( and values in our example of 1 2 3 - for example arrGps(0)=1 ) so the Ubound returns 2 - but we want 3 elements
' 3d) fill my arrOut()
Dim Stear As Variant ' I want to use a For ´Each loop below VBA must have an object varaible or a variable of variant type to hold each item in a collection of something. Our arrGps() can be considered a collection of numbers 1 2 3
Dim ArrOutRw As Long: Let ArrOutRw = 1 ' Our row number in the outout array : I use 1 initially, for the header
Let arrOut(ArrOutRw, 1) = arrDtaIn(1, 1): Let arrOut(ArrOutRw, 2) = "Deafault item"
For Each Stear In arrGps() ' This outer loop goes throug each unique group number =============== - For each number in { 1, 2, 3 }
For cnt = 2 To Lr ' An Inner loop to go through all data rows ' -----------------------------
If CStr(arrDtaIn(cnt, 1)) = CStr(Stear) Then ' This will catch the first use of our group number, Stear is our group number taken from the array 1 2 3
Let ArrOutRw = ArrOutRw + 1 ' Our next row to fill in arrOut()
Let arrOut(ArrOutRw, 1) = Stear ' First column in our output array
Let arrOut(ArrOutRw, 2) = arrDtaIn(cnt, 2) ' Second column in our output array will be given the first item in column B of our data for this group number, Stear
Exit For ' I only want to get the first item for a group number
Else
End If
Next cnt ' ----------------------------------------------------------------------------------
Next Stear ' ====================================================================================
' at this point we have an array for output of default : Select ArrOut then Hit F9.JPG : https://imgur.com/CNMeYV9
Rem 4 Demo Output
Let rngIn.Offset(0, ClmCnt).Resize(UBound(arrOut(), 1), 2).Value = arrOut() ' In the range which offset to the right of the input, of the dimension size of the output array, I paste my values out
End Sub
5 Attachment(s)
Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Extra notes in support of this Thread:
http://www.excelfox.com/forum/showth...364-Delete-row
http://www.excelfox.com/forum/showth...ll=1#post11463
http://www.excelfox.com/forum/showthread.php/2364-Delete-row
Making Lr dynamic
( using rng.End(XlUp) for a single column. )
For example, from http://www.excelfox.com/forum/showth...364-Delete-row :
BasketOrder.xlsx for column C, Lr is 6
( BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
)
_____ Workbook: BasketOrder.xlsx ( Using Excel 2007 32 bit )
| Row\Col |
B |
C |
D |
|---|
| 1 |
EQ |
ACC |
NA |
| 2 |
EQ |
ADANIPORTS |
NA |
| 3 |
EQ |
AMBUJACEM |
NA |
| 4 |
EQ |
ASIANPAINT |
NA |
| 5 |
EQ |
AXISBANK |
NA |
| 6 |
EQ |
BANKBARODA |
NA |
| 7 |
|
|
|
Lr2, for column C is :
Ws2.Range("C" & Ws2.Rows.Count).End(xlUp).Row
or
Ws2.Cells.Item(Ws2.Rows.Count, 3).End(xlUp).Row
or
Ws2.Cells.Item(Ws2.Rows.Count, "C").End(xlUp).Row
To explain:
'_- 1 :- Rows.Count Property of a worksheet
Ws2.Range("C" & Ws2.Rows.Count)
or
Ws2.Cells.Item(Ws2.Rows.Count, 3)
or
Ws2.Cells.Item(Ws2.Rows.Count, "C")
For Excel 2007 and higher versions ( .xlsx .xlsm ), this is 1048576 rows in a worksheet ( ImmediateWindow RowsCount XL 2007.JPG : https://imgur.com/NHHdylV )
Ws2.Range("C" & 1048576)
or
Ws2.Cells.Item(1048576, 3)
or
Ws2.Cells.Item(1048576, "C")
This is the last cell in column C:
_____ Workbook: BasketOrder.xlsx ( Using Excel 2007 32 bit )
| Row\Col |
B |
C |
D |
|---|
| 1048574 |
|
|
|
| 1048575 |
|
|
|
| 1048576 |
|
|
|
So we are at the bottom of the worksheet….
'_- 2 :- .End(xlUp) Property action
This is the same as keyboard keys _ Ctrl+UpArrow
Ctrl + UpArrow.JPG : https://imgur.com/w5w8KxZ
….This action will take you back up to the next filled cell:
_End(XlUp).JPG : https://imgur.com/JQJxc1s
….So we are at the last filled cell in column C
'_- 3 :- .Row Property
This will give you the row number of the cell
_Row.JPG : https://imgur.com/bMpaBOv
For example, from http://www.excelfox.com/forum/showth...364-Delete-row :
1.xls for column B, Lr is 7
( 1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e )
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
|---|
| 1 |
Exchange |
Symbol |
Series/Expiry |
| 2 |
NSE |
ADANIPORTS |
EQ |
| 3 |
NSE |
ABC |
EQ |
| 4 |
NSE |
ASIANPAINT |
EQ |
| 5 |
NSE |
AXISBANK |
EQ |
| 6 |
NSE |
BANKBARODA |
EQ |
| 7 |
NSE |
BHARTIARTL |
EQ |
| 8 |
|
|
|
Lr1, for column B is :
Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row
or
Ws1.Cells.Item(Ws1.Rows.Count, 2).End(xlUp).Row
or
Ws1.Cells.Item(Ws1.Rows.Count, "B").End(xlUp).Row
To explain:
'_- 1 :- Rows.Count Property of a worksheet
Ws1.Range("B" & Ws1.Rows.Count)
or
Ws1.Cells.Item(Ws1.Rows.Count, 2)
or
Ws1.Cells.Item(Ws1.Rows.Count, "B")
For Excel 97 - 2003 ( .xls ), this is 65536 rows in a worksheet ( ImmediateWindow RowsCount XL 2003.JPG : https://imgur.com/iOmrf9n )
Ws1.Range("B" & 65536 ))
or
Ws1.Cells.Item( 65536 , 2)
or
Ws1.Cells.Item( 65536 , "B")
This is the last cell in column B:
(Last Worksheet Row in XL 2003.JPG : https://imgur.com/iaEPoZG )
Attachment 2401
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
|---|
| 65533 |
|
|
|
| 65534 |
|
|
|
| 65535 |
|
|
|
| 65536 |
|
|
|
So we are at the bottom of the worksheet …
'_- 2 :- .End(xlUp) Property action
This is the same as keyboard keys _ Ctrl+UpArrow
Ctrl + UpArrow.JPG : https://imgur.com/w5w8KxZ
Attachment 2402
…This action will take you back up to the next filled cell:
_End(XlUp) XL2003.JPG : https://imgur.com/JYPd95V
Attachment 2403
….So we are at the last filled cell in column B
'_- 3 :- .Row Property
This will give you the row number of the cell
_ Row.JPG : https://imgur.com/ZWCFvmr
Attachment 2404
Example Demo
For uploaded files..
BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e
run this macro
Code:
Sub Vixer8_MakingLrDynamic() ' http://www.excelfox.com/forum/showthread.php/2364-Delete-row?p=11463&viewfull=1#post11463
'
Rem 1 Workbook and worksheets info
'1a) Workbook info
Dim Wbm As Workbook: Set Wbm = ThisWorkbook ' The workbook containing macro
Dim Wb1 As Workbook, Wb2 As Workbook ' (These will be set later when the workbooks are opened)
Dim strWb1 As String: Let strWb1 = "1.xls" ' --- 1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e
Dim strWb2 As String: Let strWb2 = "BasketOrder.xlsx" ' "BasketOrder..xlsx" --- BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
'1b) Worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet ' (These will be set later when the workbooks are opened)
' Dim Lr1 As Long, Lr2 As Long ' To be determined from files : Let Lr1 = 7: Lr2 = 6 ' For sample files
Rem 2 Open files ..... we have to Open all the files all files are closed except the vba placed file
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\BasketOrder..xlsx"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb2
Set Wb2 = ActiveWorkbook '
Set Ws2 = Wb2.Worksheets.Item(1)
' Workbooks.Open Filename:="F:\Excel0202015Jan2016\ExcelFox\vixer\1.xls"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strWb1
Set Wb1 = ActiveWorkbook ' The workbook just opened will now be the current active workbook
Set Ws1 = Wb1.Worksheets.Item(1)
Rem 3 making Lr dynamic
Dim Lr2 As Long
Let Lr2 = Ws2.Range("C" & Ws2.Rows.Count).End(xlUp).Row
Let Lr2 = Ws2.Cells.Item(Ws2.Rows.Count, 3).End(xlUp).Row
Let Lr2 = Ws2.Cells.Item(Ws2.Rows.Count, "C").End(xlUp).Row
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, 2).End(xlUp).Row
Let Lr1 = Ws1.Cells.Item(Ws1.Rows.Count, "B").End(xlUp).Row
'3b) demo
Ws2.Activate
MsgBox prompt:="Lr in worksheet " & Ws2.Name & ", in workbook " & Wb2.Name & " is " & Lr2 & vbCrLf & "(last row in worksheet is " & Ws2.Rows.Count & ")"
Ws1.Activate
MsgBox prompt:="Lr in worksheet " & Ws1.Name & ", in workbook " & Wb1.Name & " is " & Lr1 & vbCrLf & "(last row in worksheet is " & Ws1.Rows.Count & ")"
Rem 4 close files
Wb2.Close: Wb1.Close
End Sub
Ref:
https://www.excelforum.com/hello-int...ess-forum.html
http://www.excelfox.com/forum/showth...ll=1#post10192
http://www.excelfox.com/forum/showth...1466#post11466
BasketOrder.xlsx : https://app.box.com/s/v4b19po7jtjmh7wcswykbij3y896dv05
1.xls : https://app.box.com/s/beqlzzl3nwjff2ocyz4ox8twu5jnqd6e
