Results 1 to 10 of 190

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
    9,521
    Rep Power
    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
    Worksheet: Sorting



    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
    Worksheet: Sorting
    Last edited by DocAElstein; 02-19-2019 at 10:57 PM.
    A Folk, A Forum, A Fuhrer …. Heil Schicklgruber

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
  •