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

[DocAElstein]

Sub subArrayMergeSort( _
            ByRef vpArray As Variant, _
            ByVal lngpElement As Long, _
            Optional vpMirror As Variant, _
            Optional ByVal lngpLeft As Long, _
            Optional ByVal lngpRight As Long _
            )
' http://www.vbforums.com/showthread.php?t=473677
'
' Recurse Merge Sort a TWO Dim array.
'
' Use...
'  subMergeSort Array, Element
'
' lngpLeft and lngpRight are 0 at the start.
'
' Sorts on ONE element.
'

Dim blnlRightIsLessThanLeft As Boolean
Dim blnlLeftIsGreaterThanRight As Boolean
Dim blnlIsNumeric As Boolean
Dim lnglLeftStart As Long
Dim lnglMid As Long
Dim lnglOutputStart As Long
Dim lnglRightStart As Long
Dim vlSwap As Variant
Dim lnglCElement As Long
Dim lnglNumElements As Long
Dim vlSwapRow() As Variant

' This is just to gain a tiiiny bit of speed.
If IsNumeric(vpArray(0, lngpElement)) = True Then
  blnlIsNumeric = True
Else
  blnlIsNumeric = False
End If

lnglNumElements = UBound(vpArray, 2)
ReDim vlSwapRow(lnglNumElements)
If lngpRight = 0 Then
  lngpLeft = LBound(vpArray, 1)
  lngpRight = UBound(vpArray, 1)
  ReDim vpMirror(lngpLeft To lngpRight, 0 To lnglNumElements)
End If
lnglMid = lngpRight - lngpLeft

Select Case lnglMid
Case 0

Case 1
  
  ' Changed this to make it case insensitive.
  ' If vpArray(lngpLeft) > vpArray(lngpRight) Then
  If blnlIsNumeric = True Then
    If CLng(vpArray(lngpLeft, lngpElement)) _
      > CLng(vpArray(lngpRight, lngpElement)) _
    Then
        blnlLeftIsGreaterThanRight = True
    Else
        blnlLeftIsGreaterThanRight = False
    End If
  Else
    If StrComp( _
        vpArray(lngpLeft, lngpElement), _
        vpArray(lngpRight, lngpElement), _
        vbTextCompare) _
        = 1 _
    Then
      blnlLeftIsGreaterThanRight = True
    Else
      blnlLeftIsGreaterThanRight = False
    End If
  End If
  
  If blnlLeftIsGreaterThanRight Then
    
    ' SWAP the whole row.
    For lnglCElement = 0 To lnglNumElements
      vlSwapRow(lnglCElement) = vpArray(lngpLeft, lnglCElement)
    Next lnglCElement
    
    For lnglCElement = 0 To lnglNumElements
      vpArray(lngpLeft, lnglCElement) = vpArray(lngpRight, lnglCElement)
    Next lnglCElement
    
    For lnglCElement = 0 To lnglNumElements
      vpArray(lngpRight, lnglCElement) = vlSwapRow(lnglCElement)
    Next lnglCElement
    
'    vlSwap = vpArray(lngpLeft)
'    vpArray(lngpLeft) = vpArray(lngpRight)
'    vpArray(lngpRight) = vlSwap
  
  End If

Case Else
  
  lnglMid = lnglMid \ 2 + lngpLeft
  subArrayMergeSort vpArray, lngpElement, vpMirror, lngpLeft, lnglMid
  subArrayMergeSort vpArray, lngpElement, vpMirror, lnglMid + 1, lngpRight

  ' Merge the resulting halves
  
  lnglLeftStart = lngpLeft ' start of first (left) half
  lnglRightStart = lnglMid + 1  ' start of second (right) half
  lnglOutputStart = lngpLeft  ' start of output (mirror array)
  
  Do
    
    ' Changed this to make it case insensitive.
    ' If vpArray(lnglRightStart) < vpArray(lnglLeftStart) Then
    
    If blnlIsNumeric = True Then
    
      If CLng(vpArray(lnglRightStart, lngpElement)) _
          < CLng(vpArray(lnglLeftStart, lngpElement)) _
      Then
        blnlRightIsLessThanLeft = True
      Else
        blnlRightIsLessThanLeft = False
      End If
    Else
      If StrComp( _
          vpArray(lnglRightStart, lngpElement), _
          vpArray(lnglLeftStart, lngpElement), _
          vbTextCompare) = _
          -1 _
      Then
        blnlRightIsLessThanLeft = True
      Else
        blnlRightIsLessThanLeft = False
      End If
    End If
    
    If blnlRightIsLessThanLeft Then
    
      ' COPY the complete row.
'      vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
      For lnglCElement = 0 To lnglNumElements
        vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
      Next lnglCElement
      
      
      lnglRightStart = lnglRightStart + 1
      If lnglRightStart > lngpRight Then
        For lnglLeftStart = lnglLeftStart To lnglMid
          lnglOutputStart = lnglOutputStart + 1
          
          ' COPY the whole row.
'          vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
          For lnglCElement = 0 To lnglNumElements
            vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
          Next lnglCElement
                 
        Next
        Exit Do
      End If
    Else
    
      ' COPY the complete row.
'      vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
      For lnglCElement = 0 To lnglNumElements
        vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
      Next lnglCElement
      
      
      lnglLeftStart = lnglLeftStart + 1
      If lnglLeftStart > lnglMid Then
        For lnglRightStart = lnglRightStart To lngpRight
          lnglOutputStart = lnglOutputStart + 1
          
          ' COPY the complete row.
'          vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
          For lnglCElement = 0 To lnglNumElements
            vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
          Next lnglCElement
          
        Next
        
        Exit Do
      End If
    End If
    
    lnglOutputStart = lnglOutputStart + 1
  
  Loop
  For lnglOutputStart = lngpLeft To lngpRight
    
    ' Swap the complete row.
'    vpArray(lnglOutputStart) = vpMirror(lnglOutputStart)
    For lnglCElement = 0 To lnglNumElements
      vpArray(lnglOutputStart, lnglCElement) = vpMirror(lnglOutputStart, lnglCElement)
    Next lnglCElement
    
  Next
End Select

' *********************************************************************
End Sub