VBA Filter for Columns instead of Rows. Phillip Filters
Coding for answer to this Thread
https://www.eileenslounge.com/viewto...p?f=30&t=31740
There are two main routines. They both are event routines reacting when the range A2 : A_ last data row is used.
A selection change routine will make the drop down list the first time that a cell is selected.
A value change routine, ( in the next post ) , makes a filtered range containing just columns having the selected value in that selected row
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
This makes a drop down list in column A when a cell is selected ( The range of ordered values needed to fill the drop down lists is made by this routine and it is placed in a worksheet with Name "DataSaladinValagationLists" )
This is briefly how this routine works:
It only does anything for a selection in the A column range.
It only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
The range of data for that row is copied to the clipboard, excluding empty cells . The text held in the clipboard is retrieved.
A row in Excel is held in the clipboard as a string with a vbTab as separator, and this string also has a trailing vbCr & vbLf which we remove. http://www.eileenslounge.com/viewtop...=31395#p242941
A 1 Dimensional array is made from the retrieved string, strSptInDrpPlop() , and this is used to produce a simple string which only has unique cell values in it. This string is then used to replace the strSptInDrpPlop() contents with unique values
The unique values as well as a leading “-“ and trailing “Blank” are pasted out to the worksheet "DataSaladinValagationLists"
Code:
Sub test()
Let Application.EnableEvents = True
Call Worksheet_SelectionChange(Me.Range("A3"))
Let Application.EnableEvents = True
End Sub
' =DataSaladinValagationLists!A2:A3
Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' for initial making of list for drop down
If IsArray(Target.Value) Then Exit Sub
Rem 1 main worksheet data range info
Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range.
If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub ' We already have made a drop down list - only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
Rem 2 make drop down list for this row
' 2a) get unique list of all values in row
Let Application.EnableEvents = False
Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy ' The range of data for that row is copied to the clipboard, excluding empty cells
Let Application.EnableEvents = True
Dim Dtaobj As Object ' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ http://www.eileenslounge.com/viewtopic.php?f=30&t=31547#p244124
Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText()
Let strClip = Left(strClip, Len(strClip) - 2) ' Take off last vbCr & vbLf
Application.CutCopyMode = False ' Clear clipboard, stop screen flicker
Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare) ' a row in Excel is held as a string with a vbTab as seperator. The array made here may contain duplicated cell values
Dim UnEeks As String: Let UnEeks = " " ' this string will have unique cell values only. I need an initial " " to make sure i can check for a number like " 7 " not just "7" as that might get confused with "27"
Dim Cnt As Long
For Cnt = 0 To UBound(strSptInDrpPlop())
If InStr(1, UnEeks, " " & Trim(strSptInDrpPlop(Cnt)) & " ", vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then ' I am not sure yet if the last check is needed.
Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " " ' A similar string to the original retrieved from the clipboard strClip is made with the difference that the seperator is a space and we have no duplicated cell values
Else
End If
Next Cnt
'Let UnEeks = Replace(UnEeks, vbTab, "", 1, -1, vbBinaryCompare) 'remove rogue vbtabs
Let UnEeks = Mid(UnEeks, 2, Len(UnEeks) - 2) ' take off first and last " " ' Left(UnEeks, Len(UnEeks) - 3) ' take off " " & vbCr & vbLf
'Let UnEeks = "-" & " " & UnEeks & "Blanks"
Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare) ' Replace the 1 Dimensional array values with only unique values
' 2b) sort list ( Bubble sort )
Dim Eye As Long, Jay As Long
For Eye = 0 To UBound(strSptInDrpPlop()) - 1 'I want to take the next in the array, starting at the first. The process below should result in the smallest being put at this position, because I go through the rest , the inner Jay loop, and when ever i find something smaller i swap so the smalles comes here
For Jay = Eye + 1 To UBound(strSptInDrpPlop()) ' I now go through comparing with each of the rest, the Jays
If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then ' This is to overcome an extra problem that I have: I have strings, and VBA thinks that "6" is bigger than "35" but it thinks 6 is less than 35
If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) 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 Eye. By the next Eye, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next Eye
Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
Else
End If
Else ' if we have text, then VBA still allows a comparison to sort - like B > A returns True
If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then
Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp ' The element being compared with all the rest is bigger, so we swap it. The effect of this is that the smallest in the rest of the list being looked at, ( The Jay loop ) , will finally end up in the current Eye position.
Else
End If
End If
Next Jay
Next Eye
' 2c) paste in values in DataSaladinValagationLists worksheet
With Worksheets("DataSaladinValagationLists")
Let .Range("A" & Target.Row & "").Value = "-" ' ' a leading "-" ,
Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop() ' unique values
Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank" ' ' and trailing "Blank"
End With
' 2d) Make dropdown list
Target.Validation.Delete ' This is only necerssary if a drop down is already there
Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & ""
End Sub
Sub testieCLDoWhile()
Dim testieletter As String
Let testieletter = CLDoWhile(3) ' should return "C"
End Sub
' CLDoWhile is a Function to get column letter from column number
Function CLDoWhile(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 CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
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
'
'
Code:
Sub testsort()
Dim df As String, d As String
df = "df"
Dim var
If IsNumeric(df) Then var = CLng(df)
Dim dg As String
dg = "dg"
MsgBox (dg > df) & " " & (dg > d)
MsgBox "7" < "77"
Dim seven As String, seventyseven As String
Let seven = "7": Let seventyseven = "77"
MsgBox seven < seventyseven
If seven < seventyseven Then MsgBox "True"
Dim arrStr(0 To 1) As String
Let arrStr(0) = "7": Let arrStr(1) = "77"
MsgBox arrStr(0) < arrStr(1)
MsgBox "6" < "34" ' FALSE !!!!!!!!!!******************
End Sub
Filter for columns not for rows. Phill Turd Sorted
continued from last post.......
Private Sub Worksheet_Change(ByVal Target As Range)
This reacts to changes of values in column A, for example when selecting a value from the drop down list
Initially a "Blank" selection is changed to "" , and if a "-" was given then the original range is restored
The rest of this routine is very similar to the routine here https://www.eileenslounge.com/viewto...245286#p245218 The difference is that we need here now to determine one set of column indices to use in a code line like pseudo the following to get the required filtered range
Output() = Index ( Cells , allRowIndicies , someColumnIndicies)
( The previous example at that link required all columns and 2 sets of some rows for two outputs based on a column having a Y or not )
Code:
Sub testieCLDoWhile()
Dim testieletter As String
Let testieletter = CLDoWhile(3) ' should return "C"
End Sub
' CLDoWhile is a Function to get column letter from column number
Function CLDoWhile(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 CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
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
'
'
Sub testieWksChange()
Call Worksheet_Change(Me.Range("A2"))
Let Application.EnableEvents = True ' Just incase it got turned off
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub
Rem 1 main worksheet data range info
Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range.
Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True
Rem 2 test data range reset
If Target.Value = "-" Then
Let Application.EnableEvents = False
Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value
Let Application.EnableEvents = True
Rem 3 Get indices( column numbers) for required columns, and all row indicies
'3a) indices( column numbers) for required columns
Else ' selected value is a unique value or "" for "Blank"
Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value ' I dont need the first and third column, but it makes it easier to keep track of the correct columns indicie
Dim Cnt As Long
Dim strClms As String: Let strClms = "1 2 " ' For our required columns containing in this row the target selected value
For Cnt = 3 To CntClms ' check columns from 3 for a match to the value in column 1
If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then ' This is indication of wanted column as it contains the value
Let strClms = strClms & Cnt & " "
Else
End If
Next Cnt
Let strClms = Left(strClms, Len(strClms) - 1) ' Take off last " "
Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare)
Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1) ' for {1,2,7,9} = required columns
For Cnt = 0 To UBound(clmsSpt())
Let Clms(Cnt + 1) = clmsSpt(Cnt)
Next Cnt
'3b) all data ro indicies
Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")") ' = {1;2;3;4;5;6;7;8;9;.......... , CntItms} = required rows ( all rows are required )
Rem 4 Output filtered columns
Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms())
Let Application.EnableEvents = False
Me.Cells.ClearContents
Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
Let Application.EnableEvents = True
End If
End Sub
Sub testsort()
Dim df As String, d As String
df = "df"
Dim var
If IsNumeric(df) Then var = CLng(df)
Dim dg As String
dg = "dg"
MsgBox (dg > df) & " " & (dg > d)
End Sub
5 Attachment(s)
Sir Narios ... Positioning of procedure separation in the Visual Basic Development Environment
Positioning of procedure separation Line in the Visual Basic Development Environment
These are some notes based on a discussion here.. http://www.eileenslounge.com/viewtopic.php?f=30&t=31756
Lisa Green had noticed something strange in how VBA divides procedures.....
It appears that in VBA, that is to say in the Visual Basic Development Environment Window , ( that window seen by hitting Alt+F11 from a spreadsheet ) , the convention has been set to separate procedures by a line extending across the code pane Window.
We see these as appearing as a series of underscores, __________________ , extending across the Visual Basic Development Environment Window
Code:
End Sub ' The dividing line appears to us as a line of underscores ____
Usually, if we did write exactly this ' The dividing line appears to us as a line of underscores ____ ' , on that terminating line above , then we would not see those underscores, ____ , as they get hidden in the terminating line:
Hidden_____InDividingLine.JPG : https://imgur.com/7DyP9Om
Attachment 2142
The above screenshot shows the simplest case of routines with no “space” in between. In that simple case, the position of the dividing line is as expected in between the procedures. The situation is a bit more complicated if there is a separation in between procedures….
Effect of blank lines ( or ‘commented lines ) In Between
Between procedures we may add blank lines or ' comment lines. If this is done, it appears that the convention has been set to place the line somewhere between the procedures in this blank/ ‘comment range, and the lines above the line “belong” to the procedure above, that is to say the last or preeceding procedure, and the lines below the line “belong” to the procedure below, that is to say the next procedure, http://www.eileenslounge.com/viewtop...=31756#p245845
The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________
Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _
Line continuation / Break points : single underscores _
We note in passing , that single underscores are used in coding generally to allow us to divide a single line of code into several lines for ease of reading. For example:
Code:
' http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row-*SOLVED*?p=10891#post10891
Sub LineContunuationUnderscores() ' https://docs.microsoft.com/en-us/dotnet/visual-basic/programming-guide/program-structure/how-to-break-and-combine-statements-in-code
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Without line breaks
Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))
' With Line breaks
LastRow = _
Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & LastRow) = Evaluate(Replace(Replace( _
"IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(" & _
"A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)" & _
"=""2018"",TRIM(A1:A@&"" ""&A2:A#),"""")," & _
"IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", _
LastRow + 1), "@", LastRow))
' This is _
acceptable in _
or out of a procedure
End Sub
' This is _
acceptable in _
or out of a procedure__________________________________________________________________________________________________________________________________________________________________________________________________________________________________________________________
Further, we note that the line continuation , sometimes called a line break, _ , also applies to comments whether in a procedure or between procedures:
' This is _
acceptable in _
or out of a procedure
_._________
Determining position of horizontal line dividing procedures when blank or comment lines are between procedures
Sir Narios .
The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________
Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _
There appear to be 3 scenarios to consider in order to place the line somewhere in between, ( 4 if you consider the simple case of all lines containing comments or all lines being blank )
Scenario 0
' _(0)
If all lines are blank, or all lines are full with comments ( which exclude line continuations )
No single underscores in any line
The break is immediately after the Last/ upper procedure. (This is the same as the case for no separation between routines )
Scenario 0 .JPG : https://imgur.com/pA4grFL
Attachment 2143
Code:
Sub Scenario_0()
' _(0)
End Sub___________________________________________________________________________________________________________________________________________________________________________________________________________
Sub senario_0()
' _(0)
End Sub_____________________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
'
Sub surnario_0()
' _(0)
End Sub_____________________________________________________________________________________________________________________________________________________________________________________________________________________________
Scenario 1
' _(i) Attachment 2141 SirNario_1.JPG . https://imgur.com/zmr2up2
If no line continuations are present and there is a one or more blank lines, then the line before the first blank line down from the upper routine is taken as the break point.
No single underscores in any line
Code:
Sub Senario_1()
' _(i)
End Sub
'
'________________________________________________________________________________________________________________________________________________________________________________________________________________________________
Sub surnaria_1()
' _(i)
End Sub
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
''
'
Sub Sirnario_1()
' _(i)
End Sub_______________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
Sub snaria_1()
' _(i)
End Sub
Scenario 2
' _(ii) Attachment 2144 SirNario_2.JPG : https://imgur.com/D2LqloV
If there are one or more line continuations present then the break point will be placed at the first blank line down after the last line after the line continuation … unless scenario (iii)
Code:
Sub Scnari_2()
' _(ii)
End Sub
''
'
' _
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
'
Sub Sernario_2()
' _(ii)
End Sub
'
'
' _
'
'___________________________________________________________________________________________________________________________________________________________________________________________________________________________________
'
Sub Sirnarnio_2()
' _(ii)
End Sub
Scenario 3
' _ (iii) Attachment 2146 SirNario_3.JPG : https://imgur.com/ho56uBN
There are no blank lines after the first line looking down after the last line continuation looking down, or after the first line looking down after the last line continuation looking down all lines contain comments . In this case, the break is at the line after the line on which the line continuation is on.
Code:
Sub scenario_3()
' _(iii)
End Sub
''
' _
____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
Sub SirNario_3()
' _(iii)
End Sub
'
' _
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
'
'
Sub snuaro_3()
' _(iii)
End Sub
'
'
' _
____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
Sub SirNario_3()
End Sub
'
' _
'____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
Sub SurNario_3()
End Sub
"What’s in a String"- VBA break down Loop through character contents of a string
Rotines for this excelfox Thread
http://www.excelfox.com/forum/showth...0943#post10943
This is part 1 of the coding. The second part is in the next post. The second part must be copied directly under this part in the same code module
Code:
Option Explicit '
Option Compare Binary ' https://docs.microsoft.com/de-de/dotnet/visual-basic/language-reference/statements/option-compare-statement
Sub TestWtchaGot()
' In the practice we would likely have our string obtained from some method and would have it held in some string variable
Dim strTest As String ' "Pointer" to a "Blue Print" (or Form, Questionnaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular “Value”, or (“Values” for Objects). There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructions will tell how to do this. Theoretically a special value vbNullString is set to aid in quick checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
Let strTest = Chr(1) & "Hi" & vbCrLf & vbTab & """u."""
Call WtchaGot(strIn:=strTest)
' Call WtchaGot(Chr(1) & "Hi" & vbCrLf & vbTab & """u.""")
End Sub
Sub WtchaGot(ByVal strIn As String)
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make a Temporary Sheet, if not already there, in Current Active Workbook, for a simple list of all characters
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but iin general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim ws As Worksheet '
Set ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
ws.Activate: ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 20)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop========================================================================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Simple Array Bubble Sort Example with Range.Sort Equivalent
Coding in support of this excelfox Thread:
llkslksjjsjfaslkjflkajflkjflfjj later sajfsladj
Code:
Option Explicit
'
' Range.Sort Example
Sub RangeSortExample()
range("G13:K19").Sort Key1:=range("G13:K19").Columns("B:B"), Order1:=xlAscending, Key2:=range("G13:K19").Columns("D:D"), order2:=xlAscending, MatchCase:=False, Key3:=range("G13:K19").Columns("E:E"), order3:=xlDescending, MatchCase:=False
End Sub ' Matchcase:=False '
' Simplist Sort
Sub SimpleArraySort()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' 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 ' ========"Left Hand"=====================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-------------"Right Hand"--------------------------
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
RngToSort.Offset(0, RngToSort.Columns.Count).Clear ' WsS.Columns("C:D").Clear ' CHANGE TO SUIT
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:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Rem 1 For demo purposes we will sort a copy of the range
RngToSort.Offset(0, RngToSort.Columns.Count * 2).Clear ' WsS.Columns("E:F").Clear ' CHANGE TO SUIT
RngToSort.Copy Destination:=RngToSort.Offset(0, RngToSort.Columns.Count * 2)
Dim RngCopy As range: Set RngCopy = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlAscending, MatchCase:=False
'
Let RngCopy.Interior.Color = vbGreen
End Sub
Typical results:
The sorted array is displayed in the spreadsheet along side the original range used as test data for the inputted array. ( The yellow highlighted range is that produced by the array sort routine, Sub SimpleArraySort() , and the green highlighted range is that produced by the VBA Range.Sort method routine, Sub Range_Sort()
More examples in next post.
_____ ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
D |
E |
F |
G |
|---|
1 |
|
|
|
|
|
|
|
2 |
c |
WasB2 |
A |
WasB5 |
A |
WasB5 |
|
3 |
AB |
WasB3 |
Aa |
WasB4 |
Aa |
WasB4 |
|
4 |
Aa |
WasB4 |
AB |
WasB3 |
AB |
WasB3 |
|
5 |
A |
WasB5 |
B |
WasB7 |
B |
WasB7 |
|
6 |
C |
WasB6 |
b |
WasB8 |
b |
WasB8 |
|
7 |
B |
WasB7 |
bcde |
WasB9 |
bcde |
WasB9 |
|
8 |
b |
WasB8 |
C |
WasB6 |
c |
WasB2 |
|
9 |
bcde |
WasB9 |
c |
WasB2 |
C |
WasB6 |
|
10 |
|
|
|
|
|
|
|
Simpla Array Bubble Sort Program allowing for Ascending or Descending order
The last routine, Sub TestieSimpleArraySort(), has a section dupilcated to allow for selection of a final list sorted in Ascending or descending order.
If supplied 0, or , no GlLl argument is given, then the final list should be sorted in Ascending order
Code:
' Simplist Sort2
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(0)
End Sub
'
Sub SimpleArraySort2(Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' 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 ' ========"Left Hand"=====================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-------------"Right Hand"--------------------------
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 GlLl = 0 Then ' We want Ascending list
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
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
Else ' GlLl is not 0 , so presumably we want Descending list
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
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear ' WsS.Columns("C:D").Clear ' CHANGE TO SUIT
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub
Results for this callind procedure
Code:
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(0)
Call SimpleArraySort
End Sub
'
_____ ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
D |
|---|
2 |
c |
WasB2 |
32 |
WasB8 |
3 |
AB |
WasB3 |
6 |
WasB7 |
4 |
Aa |
WasB4 |
A |
WasB5 |
5 |
A |
WasB5 |
Aa |
WasB4 |
6 |
C |
WasB6 |
AB |
WasB3 |
7 |
6 |
WasB7 |
bcde |
WasB9 |
8 |
32 |
WasB8 |
C |
WasB6 |
9 |
bcde |
WasB9 |
c |
WasB2 |
Results for this calling procedure
Code:
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(732847)
End Sub
'
_____ ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
D |
|---|
2 |
c |
WasB2 |
c |
WasB2 |
3 |
AB |
WasB3 |
C |
WasB6 |
4 |
Aa |
WasB4 |
bcde |
WasB9 |
5 |
A |
WasB5 |
AB |
WasB3 |
6 |
C |
WasB6 |
Aa |
WasB4 |
7 |
6 |
WasB7 |
A |
WasB5 |
8 |
32 |
WasB8 |
6 |
WasB7 |
9 |
bcde |
WasB9 |
32 |
WasB8 |
Simple Array Bubble Sort Example working similar to VBA Range.Sort with one Key1:=
A further modification is done to the previous routines so that values that can be seen as numbers are compared as numbers in sorting. This is done so that, for example, a number like 46 would be seen as greater than 7. In previous routines, these would be compared as text values of "46" and "7". In a text comparison, the sort is done initially on the first character so that "4" would be seen as less that "7". ( The second character, "6", in this exampple is not used. A second character would only be used to sort if we had two values such as "46" and "49". In such an example VBA would place "49" above "46" for a text comparison
We find that the VBA Range.Sort Method sees text as text and numbers typically as numbers , and the final purpose of the routines we are developing in the associated main forum Thread is to do somethhing similar to the VBA Range.Sort Method
Code:
'
' Simplist Sort3
Sub TestieSimpleArraySort3()
Call SimpleArraySort3(0)
End Sub
'
Sub SimpleArraySort3(Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' 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 ' ========"Left Hand"=====================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-------------"Right Hand"--------------------------
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 GlLl = 0 Then ' We want Ascending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then ' Numeric case
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then' If both values are seen to be numeric then this line would probably work, but as "belt and braces" we do the next
If CDbl(arrOut(rOuter, Clm)) > CDbl(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
Else ' Non numeric case
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then
If CDbl(arrOut(rOuter, Clm)) < CDbl(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
Else ' non numeric case
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
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear ' WsS.Columns("C:D").Clear ' CHANGE TO SUIT
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub
Final comparison results are shown in the next post
First step in turning Bubble Sort routine into function. Routine takes in an Array (ByRef) to sort
Code:
'
Sub TestieSimpleArraySort4()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
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
Call SimpleArraySort4(arrTS(), 0)
End Sub
Sub SimpleArraySort4(ByRef arrTS() As Variant, Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' 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 ' ========"Left Hand"=====================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-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then ' Numeric case
If CDbl(arrOut(rOuter, Clm)) > CDbl(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
Else ' Non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then
If CDbl(arrOut(rOuter, Clm)) < CDbl(arrOut(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) < UCase(CStr(arrOut(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub
Initial Function for Simple Bubble Sort
In the routines
Sub TestieSimpleArraySort5() and Function SimpleArraySort5(______) As Variant
below , the main difference over the previous routines is the extra As Variant at the signature line, and finally a code line just before End Function of SimpleArraySort5 = arsRef()
In the testieing routine, we use codes line of this form in the conventional way in which a function is typically used.
_ arrTS() = SimpleArraySort5(arrTS(), _ 0 _ )
But we note that by virtue of using ByRef a simple call would surfice
_Call SimpleArraySort5(arrTS(), _ 0 _ )
Note: we have added an extra testing code section '2b)
In this extra section we fill a new array, arrDesc() , with the sorted array in Descending order. We use for demo purposes a typical function using code line
_ arrDesc() = SimpleArraySort5(arrTS(), 2136)
Correspondingly we have a demo output giving code line
_ RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrDesc()
We note further, that this is somewhat redundant. This is because the code part SimpleArraySort5(arrTS(), 2136) has the effect of re filling arrTS() with the newly sorted array by virtue of the use of ByRef in the signature line of the Function
We could therefore simply use a code line like _..
_Call SimpleArraySort5(arrTS(), 357)
_.. followed by an demo output giving line of
_ RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrTS()
Code:
Sub TestieSimpleArraySort5()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' 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
Call SimpleArraySort5(arrTS(), 0)
Let arrTS() = SimpleArraySort5(arrTS(), 0)
Rem 2 Output for easy of demo
' 2a) Ascending
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) Descending ( using diiffernet variable )
Dim arrDesc() As Variant
Let arrDesc() = SimpleArraySort5(arrTS(), 2136)
RngToSort.Offset(0, RngToSort.Columns.Count * 3).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrDesc()
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrTS() ' Because we use ByRef this would work after any normal Call of SimpleArraySort5(arrTS(), ) The actual call we use puts the sorted array in arrTS() The important bit is SimpleArraySort5(arrTS(), ) After this arrTS() with the newly sorted array by virtue of the use of ByRe in the signature line of this Function has the effect of refilling arrTS() with the newly sorted in descending order values
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Interior.Color = vbYellow
End Sub
Function SimpleArraySort5(ByRef arsRef() As Variant, Optional ByVal GlLl As Long) As Variant
' 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 ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arsRef(), 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-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arsRef(), 1)
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
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
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Let SimpleArraySort5 = arsRef()
End Function
In the next post are some typical test results for the above coding
Final Demo of recursion array sort on multi coliumns
Take an example,
A list of Foods, their name in first column and a few other things like calories(Kcal) and Salt content in other columns
First I want to sort to group similar products (based on alphabetical order, but ascending or descending is not important) - This will be sorting on column 1 values
Within similar food types, I want to list them in an order of how healthy they might be, ( or at least in the order of least unhealthy ) .
Most important would be order starting with lowest Kcal.
After that for similar products with similar Kcal , we would consider the minimum salt content as likely to be the less unhealthy.
This might be our list
_____ ( Using Excel 2007 32 bit )
| Row\Col |
R |
S |
T |
U |
V |
W |
|---|
22 |
Food Product |
Was S22 |
Kcal |
Was U22 |
Salt |
Was W22 |
23 |
Crisps |
Was S23 |
500 |
Was U23 |
0.7 |
Was W23 |
24 |
Beer |
Was S24 |
200 |
Was U24 |
0.1 |
Was W24 |
25 |
Wine |
Was S25 |
150 |
Was U25 |
0.15 |
Was W25 |
26 |
Beer |
Was S26 |
200 |
Was U26 |
0.07 |
Was W26 |
27 |
beer |
Was S27 |
220 |
Was U27 |
0.2 |
Was W27 |
28 |
Beer |
Was S28 |
210 |
Was U28 |
0.06 |
Was W28 |
29 |
Wine |
Was S29 |
160 |
Was U29 |
0.04 |
Was W29 |
30 |
wiNe |
Was S30 |
150 |
Was U30 |
0.03 |
Was W30 |
31 |
Crisps |
Was S31 |
502 |
Was U31 |
2 |
Was W31 |
32 |
Onion Ringes |
Was S32 |
480 |
Was U32 |
1 |
Was W32 |
33 |
Onion Ringes |
Was S33 |
490 |
Was U33 |
1.5 |
Was W33 |
34 |
Crisps |
Was S34 |
502 |
Was U34 |
1.5 |
Was W34 |
35 |
CRISPS |
Was S35 |
500 |
Was U35 |
1.1 |
Was W35 |
36 |
Wine |
Was S36 |
170 |
Was U36 |
0.1 |
Was W36 |
37 |
Crisps |
Was S37 |
500 |
Was U37 |
3 |
Was W37 |
Here is a demo Calling test routine
Code:
Sub TestieSimpleArraySort6()
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
' Call SimpleArraySort6(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc")
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 SimpleArraySort6(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
TestRngSrt.Interior.Color = vbGreen
End Sub
'
That above routine uses the test range R23:W37 above and feeds that to the main recursion routine below in the next post. The demo routine also does the VBA Range.Sort equivalent code line
Final Main recursion Array sort using multi columns routine below
Code:
'
' Main recursion routine below : Bubble Sorting in Arrays using multi columns values for sort criteria
Sub SimpleArraySort6(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
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
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
If (2 * CopyNo) > UBound(Keys()) + 1 Then MsgBox Prompt:="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
Dim Rws() As String: Let Rws() = Split(Trim(strRws), " ", -1, vbBinaryCompare) ' We take the supplied sequential string 2 3 4 5 6 and make a 1 D array {1, 2, 3....} as it is a bit more conveniant to work with. Actually we only need the start and top numbers so we could do it with stinr manipulation instead
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = Rws(LBound(Rws())) To Rws(UBound(Rws()) - 1) ' For first row indicie to last but one row indicie
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rws(UBound(Rws())) ' from just above left hand through all the rest
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
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
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
' Captains Blog, just fo info
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
' Rem 3 Determine any duplicates in sort column values , and re run the routine to sort them by another column
Let rOuter = Rws(LBound(Rws())) - 1 ' we look for duplicates in the current list, in the loop below we add 1 each time so _ it is necersarry to start 1 before, so that +1 the first time is the start row
Let strRws = "" ' ready for use in duplicate search
Do ' Loop down the last set of sorted rows ****************************************************|
Let rOuter = rOuter + 1 ' next row number _ it was necersarry to start 1 before, so that +1 the first time is the start row
If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
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 ' when we did not have a next duplicate, we may have a few already grouped
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now Rec Call 1" ' This is done for every duplicated value section, except if we have duplicates at the last lines
Call SimpleArraySort6(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
End If ' this is the end of the stuff in most situations...
' ...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 list, so now Rec Call 2 (Dups at list end case)" ' Rec Call 2 - only done for duplicates at end of list
Call SimpleArraySort6(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... ................................................................|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub
Typical results in the next post:
Code to simulate Click on Office Clipboard Clear All Button
Code in support of these Threads:
http://www.excelfox.com/forum/showth...1018#post11018
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849
https://stackoverflow.com/questions/...ently-on-the-c
https://stackoverflow.com/questions/...60767#54960767
Code:
Private Type POINTAPI
x As Long: Y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
Dim hwndClip As LongPtr
Dim hwndScrollBar As LongPtr
Dim lngPtr As LongPtr
#Else
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Dim hwndClip As Long
Dim hwndScrollBar As Long
#End If
Const GW_CHILD = 5
Const S_OK = 0
Sub ClearOffPainBouton() 'OhFolloks
'Application.DisplayClipboardWindow = True
Dim tRect1 As RECT, tRect2 As RECT
Dim tPt As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant
Dim lResult As Long
Dim i As Long
Static bHidden As Boolean
Dim MyPain As String 'COMsOLEwollupsActivelyEmmbeddedXratedObjectHookMyBoutonOhFolloks
If CLng(Val(Application.Version)) <= 11 Then
Let MyPain = "Task Pane"
Else
Let MyPain = "Office Clipboard"
End If
If CommandBars(MyPain).Visible = False Then
bHidden = True
CommandBars(MyPain).Visible = True
Application.OnTime Now + TimeValue("00:00:01"), "ClearOffPainBouton": Exit Sub
End If
Let hwndClip = FindWindowEx(Application.hWnd, 0, "EXCEL2", vbNullString)
Let hwndClip = FindWindowEx(hwndClip, 0, "MsoCommandBar", CommandBars(MyPain).NameLocal)
Let hwndClip = GetNextWindow(hwndClip, GW_CHILD)
Let hwndScrollBar = GetNextWindow(GetNextWindow(hwndClip, GW_CHILD), GW_CHILD)
If hwndClip And hwndScrollBar Then
GetWindowRect hwndClip, tRect1
GetWindowRect hwndScrollBar, tRect2
BringWindowToTop Application.hWnd
For i = 0 To tRect1.Right - tRect1.Left Step 50
tPt.x = tRect1.Left + i: tPt.Y = tRect1.Top - 10 + (tRect2.Top - tRect1.Top) / 2
#If VBA7 And Win64 Then
CopyMemory lngPtr, tPt, LenB(tPt)
Let lResult = AccessibleObjectFromPoint(lngPtr, oIA, vKid)
#Else
Let lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, vKid)
#End If ' ##### avec moi si vou ple La légende du bouton
If InStr("Clear All Borrar todo Effacer tout Alle löschen La légende du bouton", oIA.accName(vKid)) Then
Call oIA.accDoDefaultAction(vKid): CommandBars(MyPain).Visible = Not bHidden: bHidden = False: Exit Sub
End If
DoEvents
Next i
End If
Let CommandBars(MyPain).Visible = Not bHidden
MsgBox "Unable to clear the Office Clipboard"
End Sub
Sub TestVersion() ' Rory Archibald 2015
MsgBox prompt:=ExcelVersion
MsgBox prompt:=CLng(Val(Application.Version))
End Sub
Private Function ExcelVersion() As String
Dim Temp As String
'On Error Resume Next
#If Mac Then
Select Case CLng(Val(Application.Version))
Case 11: Temp = "Excel 2004"
Case 12: Temp = "Excel 2008" ' this should NEVER happen!
Case 14: Temp = "Excel 2011"
Case 15: Temp = "Excel 2016 (Mac)"
Case Else: Temp = "Unknown"
End Select
#Else
Select Case CLng(Val(Application.Version))
Case 9: Temp = "Excel 2000"
Case 10: Temp = "Excel 2002"
Case 11: Temp = "Excel 2003"
Case 12: Temp = "Excel 2007"
Case 14: Temp = "Excel 2010"
Case 15: Temp = "Excel 2013"
Case 16: Temp = "Excel 2016 (Windows)"
Case Else: Temp = "Unknown"
End Select
#End If
#If Win64 Then
Temp = Temp & " 64 bit"
#Else
Temp = Temp & " 32 bit"
#End If
ExcelVersion = Temp
End Function
Early Binding and Later Late Binding fo data objects
Coding in support of this post:
http://www.excelfox.com/forum/showth...ll=1#post11018
Code:
Sub MSFORMS_Early_Copy_and_Later_Late_Binding_Paste()
Rem 1 Late Binding
Dim DtaObj As MSForms.DataObject ' RefMSFORMS.JPG : https://imgur.com/8zKpyr2
Set DtaObj = New MSForms.DataObject
'Dim DtaObj As New MSForms.DataObject
Rem 1 ' Arbritrary Excel range values copy
Let Range("A1").Value = "CellA1": Let Range("A2").Value = "CellA2": Let Range("B1").Value = "CellB1": Let Range("B2").Value = "CellB2"
Rem 2 Clipboard Data object stuff - get the long string that is held in some clipboards
Range("A1:B2").Copy ' ' This seems to fill Excel, Windows and Office Clipboards http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&p=246889#p246887
' Get some string version from some clipboard using a DataObject method
' Let Application.CutCopyMode = False ' generally speaking these two code lines will not clear the Windows Clipboards,
' Call ClearOffPainBouton ' but they do for the case of a range copy having put them in. So we can't do these here
DtaObj.GetFromClipboard ' ' This is filling a regisrre and possibly sometimes setting referrences that may prevent other things being done, or put them in a Queue, bit most likely to put a spanner in the works
Let Application.CutCopyMode = False
Call ClearOffPainBouton
' Range("A1:B2").Clear ' ' This will cause us to fail .. very strange .. this could suggest that we are still holding a range referrence at this stage
Dim strGet As String: Let strGet = DtaObj.GetText()
Range("A1:B2").Clear ' At this point it is fine to do this
Rem 3 examine string
Call WtchaGot(strIn:=strGet) ' ' Function to see string : https://pastebin.com/gtLaBrf5
'3b Do some modification of the string
Let strGet = Replace(strGet, vbTab, "|", 1, -1, vbBinaryCompare) ' replace in the strGet , vbTab , with "|" pipes , I want all output so starting at first character , -1 means replace all occurances , exact match using computer exact digits
' Call ClearWindowsClipboard ' http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11020&viewfull=1#post11020 clearing the windows clipboard at this point also messes the simple reverse process from working. This makes no sense at all: Clearly clearing does not always clear things: It may do this in many occasions as one of its actions, but it can also do things which have something near to the opposite effect.
Rem 4 Replace the version previously got using another DataObject method
'4a) Simple reverse action
DtaObj.Clear ' Without this the following 2 line simple reverse action would not work
' DtaObj.SetText Text:=strGet: ' Let strGet = DtaObj.GetText() ' - This always gets the last "addition" ... https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c/54960767#54960767
' DtaObj.PutInClipboard
'4b) Later Late Binding
Dim LaterDtaObj As Object
Set LaterDtaObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'Set LaterDtaObj = CreateObject("MSForms.DataObject") ' https://bytecomb.com/copy-and-paste-in-vba/
LaterDtaObj.SetText Text:=strGet
LaterDtaObj.PutInClipboard
Rem 5 ' Excel Range Paste ( using Worksheet.Paste method https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.paste )
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
End Sub
Code:
' SHimpfGlified Coding
Sub Early_Copy_and_Later_Late_Binding_Paste()
Rem 1 Late Binding
Dim DtaObj As MSForms.DataObject ' RefMSFORMS.JPG : https://imgur.com/8zKpyr2
Set DtaObj = New MSForms.DataObject
Rem 1 ' Arbritrary Excel range values copy
Let Range("A1").Value = "CellA1": Let Range("A2").Value = "CellA2": Let Range("B1").Value = "CellB1": Let Range("B2").Value = "CellB2"
Rem 2 Clipboard Data object stuff - get the long string that is held in some clipboards
Range("A1:B2").Copy '
DtaObj.GetFromClipboard '
Dim strGet As String: Let strGet = DtaObj.GetText()
Range("A1:B2").Clear
Rem 3 examine string
' Call WtchaGot(strIn:=strGet) '
'3b Do some modification of the string
Let strGet = Replace(strGet, vbTab, "|", 1, -1, vbBinaryCompare)
Rem Simple reverse action. Later Late Binding
Dim LaterDtaObj As Object
Set LaterDtaObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
LaterDtaObj.SetText Text:=strGet
LaterDtaObj.PutInClipboard
Rem 5 ' Excel Range Paste ( using Worksheet.Paste method https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.paste )
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
End Sub
Sub TestieSimpleArraySort7() ( and Global variables and a required Function )
Global variables should go at top of code module
Code:
Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "HorizointalColumn" Indicies , "Virtical row" Indicies
Dim RngToSort As Range ' Test data range
Dim arrIndx() As Variant ' For modified array at end of each sort of a set of rows
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
Test routine to Call main recursion routine ( given in next post )
Code:
Sub TestieSimpleArraySort7()
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 SimpleArraySort7(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).Clear
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 SimpleArraySort7(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
1 Attachment(s)
Main recursion routine Sub SimpleArraySort7(
Code:
Sub SimpleArraySort7(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
If CopyNo = 1 Then Debug.Print "First procedure Call"
Rem -1 from the supplied arguments, get all data needed in current bubble sort
' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number
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
If (2 * CopyNo) > UBound(Keys()) + 1 Then MsgBox Prompt:="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
Dim Rws() As String: Let Rws() = Split(Trim(strRws), " ", -1, vbBinaryCompare) ' We take the supplied sequential string 2 3 4 5 6 and make a 1 D array {1, 2, 3....} as it is a bit more conveniant to work with. Actually we only need the start and top numbers so we could do it with stinr manipulation instead
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = Rws(LBound(Rws())) To Rws(UBound(Rws()) - 1) ' For first row indicie to last but one row indicie
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To Rws(UBound(Rws())) ' from just above left hand through all the rest
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
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
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Debug.Print "Doing an arrIndx()"
Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms())
' Captains Blog, Start Treck
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Clear ' Area for array produced from previous method
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Value = arsRef()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Clear ' Area for array produced by Index method idea
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() ' Current indicies order to apply to original range
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
' Rem 3 Determine any duplicates in sort column values , and re run the routine to sort them by another column
Let rOuter = Rws(LBound(Rws())) - 1 ' we look for duplicates in the current list, in the loop below we add 1 each time so _ it is necersarry to start 1 before, so that +1 the first time is the start row
Let strRws = "" ' ready for use in duplicate search
Do ' Loop down the last set of sorted rows ****************************************************|
Let rOuter = rOuter + 1 ' next row number _ it was necersarry to start 1 before, so that +1 the first time is the start row
If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates
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 ' when we did not have a next duplicate, we may have a few already grouped
If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list
Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now Rec Call 1" ' This is done for every duplicated value section, except if we have duplicates at the last lines
Call SimpleArraySort7(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
End If ' this is the end of the stuff in most situations...
' ...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 list, so now Rec Call 2 (Dups at list end case)" ' Rec Call 2 - only done for duplicates at end of list
Call SimpleArraySort7(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... ................................................................|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub
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
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
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
2 Attachment(s)
Some Killing File tests / What order does Dir(with wild cards) find stuff
Some notes , tests in support of this
https://www.excelforum.com/excel-pro...-the-file.html
These are just some notes and tests into what order the Dir( with wild cards ) thing does stuff.
Introduction
VBA Dir Function thing ( https://docs.microsoft.com/en-us/off...p/dir-function )
In the simplest form, ….._
_____ Dir(Fullpath&FileName, __ )
_............
Code:
Dim IsFileName As String
IsFileName = Dir("C:\MyFolder\myFileName.xls", __ )
this basically gives you the file name back if it exists, based on you giving it the full path and File name string, Fullpath&FileName.
In the above example, if you had the file "myFileName.xls" in the foilder, "MyFolder", then the text "myFileName.xls" would be Placed in variable , IsFileName
If that file does not exist, then it gives you back nothing, or rather an empty string of sorts “” ( I believe Dir is a throw back to older early computer days, when you typed something like Dir C:_____, and the result was that you got to go to that place which Dir C:_____ represented )
It seem that in VBA the Dir is mostly used to loop through all files in a single folder*. ( *It does not suit too well for use in coding looking at all files in folders and sub folders ). The suitability of the Dir function for this is based on a couple of things.
_(i) In Microsoft Windows, Dir supports the use of multiple character (*) and single character (?) wildcards to specify multiple files. ......
You can use wild cards in the full path and file name string that you give it, so it will look for a file matching your given string. ( So typically you might give a string like “C:\myFolder\*.xl*”, which would look for any excel file: In this bit *.xl* , the first * allows for any file name, and the second * will allow for extensions such as .xls , .xlsm, .xlsx, .. etc… )
__Dir _____ without arguments_(ii) After you use like Dir(Fullpath&FileName, __ ) once, then any use after of just _ Dir __ without any arguments, will give the next file it finds based on the criteria given by the wild carded full path and file name string you gave in the first use with arguments, or it returns "" if there are no further files meeting the criteria given by the wild carded full path and file name string you gave in the first use with arguments
What this post is about:
My interest was sparked by the reference thread ( https://www.excelforum.com/excel-pro...-the-file.html )
I am interested in finding out which of the files Dir or Dir(Fullpath&FileName, __ )will choose if there are more than 1 file meeting the criteria of a string , Fullpath&FileName , containing wild cards
Experiments so far
I made a test folder , named "Folder"
Folder.JPG : https://imgur.com/l9OwlQi
Attachment 2213
I created my files in this order
_1 “wbCodes.xlsm” --- the main file with all the codes in it. This is in the same Folder as the folder which I named "Folder" ( The main Folder is called “Kill Stuff” : Kill Stuff Folder.JPG : https://imgur.com/hN26AoW )
After making the main File, I created the folder, "Folder" , and created the following files in it. I created the following three files in the following order,
_2 “SecondFirstAfterwb.xlsx” --- made first after making “wbCodes.xlsm”
_3 “ThirdSecondAfterwb.xlsx” --- made second after making “wbCodes.xlsm”
_4 “AForthThirdAfterwb.xlsx” --- made third after making “wbCodes.xlsm”
I modified the codes from Alf and sintek from the referenced Thread, thus, ( I am mainly interested in the first part of the routines, as this deals with what the Dir chooses )
Code:
Sub zed369() ' sintek
Dim Path As String, File As String, Cnt As Long
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
' sintek's Dir Stuff
'Application.ScreenUpdating = False
Set wb1 = ThisWorkbook: Set ws1 = wb1.Sheets("Sheet1")
Path = ThisWorkbook.Path & "\Folder\": File = Dir(Path & "*.xl*") ' For this example, specific file is in a folder called Folder...same path as macro file...
Debug.Print "First got by Dir is " & File
Debug.Print
For Cnt = 1 To 3 - 1 ' -1 because we have three files, but typically the first is got from the first use of Dir , which is typically outside the loop
File = Dir: Debug.Print " use " & Cnt & " in loop of Dir gives " & File
Next Cnt
Debug.Print
Debug.Print
' sintek's way to do stuff
'Stop ' _____________________________________________________________________________
'Set wb2 = Workbooks.Open(Path & File): Set ws2 = wb2.Sheets("Tabelle1")
'With ws2
' .UsedRange.Copy ws1.Range("A1")
'End With
'wb2.Close
'Kill Path & File
'Application.ScreenUpdating = True
End Sub
'
Sub CopyAndKill() ' Alf
Dim aString As String, Cnt As Long, aStringToOpen As String
' Alf's Dir stuff
'aString = Dir("N:\a_test\")
aString = Dir("F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\")
Debug.Print "First got by Dir is " & aString
aStringToOpen = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\" & Dir("F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\")
Debug.Print "First file will be opened using this string " & vbCrLf & aStringToOpen
Debug.Print
For Cnt = 1 To 3 - 1 ' -1 because we have three files, but typically the first is got from the first use of Dir , which is typically outside the loop
aString = Dir: Debug.Print " use " & Cnt & " in loop of Dir gives " & aString
Next Cnt
Debug.Print
Debug.Print
'Stop ' __________________________________________________________________
' Alf's way to do the stuff
'Workbooks.Open ("N:\a_test\" & Dir("N:\a_test\"))
'Sheets("Sheet1").Activate
'ActiveSheet.UsedRange.Copy
'ThisWorkbook.ActiveSheet.Range("A1").PasteSpecial Paste:=xlAll
'Application.CutCopyMode = False
'Windows(aString).Close
'Kill ("N:\a_test\" & Dir("N:\a_test\"))
End Sub
I get this sort of output ( in the immediate window )
Code:
First got by Dir is AForthThirdAfterwb.xlsx
use 1 in loop of Dir gives SecondFirstAfterwb.xlsx
use 2 in loop of Dir gives ThirdSecondAfterwb.xlsx
First got by Dir is AForthThirdAfterwb.xlsx
First file will be opened using this string
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\AForthThirdAfterwb.xlsx
use 1 in loop of Dir gives SecondFirstAfterwb.xlsx
use 2 in loop of Dir gives ThirdSecondAfterwb.xlsx
Initially it appears that I get alphabetic order.
But possibly there could be more to it than that.
I will look again at this in a few days , possibly on some other computers and systems, and experiment with various settings , etc….
In the next posts I will use this simplified routine which is only interested in looking at the order in which Dir chooses files.
Rem 1 gives a few ways to get the string up to and including the Folder in which files are to be searched for, ( in the form below , ‘1b ) , is used to get the folder named “Folder” in the same folder as the workbook in which the routine is placed )
Rem 2 : As before, an initial use of Dir(C:\somewhers\kjhfkhs.*sdfjkah,___) is made to set the search criteria, followed by the un argumented Dir in a loop which then looks for the next files
Code:
Sub DirOrder()
Dim strWB As String
Rem 1 get the full string, strWB, for a Folder to use in the Dir(Fullpath&FileName, __ ) ( strWB=Fullpath&FileName - FileName )
'1a) use the asking pop up thing, File dialogue folder picker
' With Application.FileDialog(msoFileDialogFolderPicker)
' .Title = "Folder Select"
' .AllowMultiSelect = False
' If .Show <> -1 Then
' Exit Sub
' Else
' End If
' Let strWB = .SelectedItems(1) ' & "\"
' End With
'
'1b) Using a test Folder, named Folder in the same Folder as the workbook in which this code is
Let strWB = ThisWorkbook.Path & "\Folder"
'1c) Hard code instead
'Let strWB = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder"
Debug.Print "Folder used is" & vbCrLf & strWB & vbCrLf & "" & Right(strWB, (Len(strWB) - InStrRev(strWB, "\", -1, vbTextCompare)))
Debug.Print
Let strWB = strWB & "\"
Rem 2 add last file bit for use in the Dir(Fullpath&FileName, __ ) , but include wild cards... http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11089&viewfull=1#post11089 : _(i) You can use wild cards in the full path and file name string that you give it, so it will look for a file matching your given string. ( So typically you might give a string like “C:\myFolder\*.xl*”, which would look for any excel file: In this bit *.xl* , the first * allows for any file name, and the second * will allow for extensions such as .xls , .xlsm, .xlsx, .. etc… ) _(ii) After you use like Dir(Fullpath&FileName, __ ) once, then any use after of just _ Dir __ without any arguments, will give the next file it finds based on the string you gave in the first use with arguments
'2a) Excel files
Let strWB = strWB & "*.xls*"
Dim file As String: Let file = Dir(strWB)
Debug.Print "First got by Dir(" & strWB & ")" & vbCrLf & "is " & file
Debug.Print
Dim Cnt As Long
For Cnt = 1 To 3 - 1 ' -1 because we have three files, but typically the first is got from the first use of Dir , which is typically outside the loop
file = Dir: Debug.Print "Use " & Cnt & " in loop of unargumented Dir gives " & file
Next Cnt
Debug.Print
Debug.Print
End Sub
This would be comparible output ( in the Immedite Window ( http://www.eileenslounge.com/viewtop...247121#p247121 ) ) to the test files anf folder used so far
HTML Code:
Folder used is
F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder
Folder
First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*)
is AForthThirdAfterwb.xlsx
Use 1 in loop of unargumented Dir gives SecondFirstAfterwb.xlsx
Use 2 in loop of unargumented Dir gives ThirdSecondAfterwb.xlsx
And here is what it looks like in the explorer window:
ExpOrder1.JPG : https://imgur.com/OfQfHeH
Attachment 2224
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
