Results 1 to 10 of 193

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

Hybrid View

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

    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
    Last edited by DocAElstein; 02-22-2019 at 06:59 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
  •