Results 1 to 10 of 193

Thread: Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #11
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    10,457
    Rep Power
    10

    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
    Last edited by DocAElstein; 03-14-2019 at 11:08 PM.

Similar Threads

  1. VBA to Reply All To Latest Email Thread
    By pkearney10 in forum Outlook Help
    Replies: 11
    Last Post: 12-22-2020, 11:15 PM
  2. Appendix Thread. Diet Protokol Coding Adaptions
    By DocAElstein in forum Test Area
    Replies: 6
    Last Post: 09-05-2019, 10:45 AM
  3. Replies: 19
    Last Post: 04-20-2019, 02:38 PM
  4. Search List of my codes
    By PcMax in forum Excel Help
    Replies: 6
    Last Post: 08-03-2014, 08:38 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •