Sort HTML Table Area:   Return to List

' Macro that will Sort an area of a Table (of an HTML page) which can be copied into a Word document. Following the sort, I can simply do an Edit/SelectAll and paste it back into an HTML Editor (the area should still be selected).

Option Base 1
Public Sub Main()
On Error GoTo ERROR_HANDLER
' Startup Dialog
Btn = MsgBox("This macro will sort a section of a table that's been" & vbCrLf & _
                        "copied over from Dreamweaver -- so that it can be" & vbCrLf & _
                        "pasted right back into Dreamweaver's selection!" & vbCrLf & vbCrLf & _
                        " Do you WISH TO PROCEED??", vbOKCancel, _
                        " Startup Dialog")
If Btn = vbCancel Then GoTo FINAL_BYE
Dim Count As Integer
Count = 0
' Place at start of macro
Application.ScreenUpdating = False
MacroStartTime = Now ' Start Elapsed Timer
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Dim FindTerm(4)
    Dim ReplTerm(4)
FindTerm(1) = ""
    ReplTerm(1) = ""
FindTerm(2) = ""
    ReplTerm(2) = ""
FindTerm(3) = "href="
    ReplTerm(3) = "HREF="
FindTerm(4) = ""
    ReplTerm(4) = ""
For i = 1 To 4
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
         .Text = FindTerm(i)
         .MatchWildcards = False
         .MatchCase = True
         .Replacement.Text = ReplTerm(i)
         .Wrap = wdFindStop
         .Forward = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next
' Select the areas we're interested in
With Selection.Find
    .Text = ""
    .MatchWildcards = False
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .Forward = True
End With
Selection.Find.Execute
myStart = Selection.START
Selection.EndKey Unit:=wdStory
With Selection.Find
    .Text = ""
    .MatchWildcards = False
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .Forward = False
End With
Selection.Find.Execute
myEnd = Selection.End
ActiveDocument.Range(START:=myStart, End:=myEnd).Select
' Parse the selected table into an array
strTable = Selection.Text
Dim aryTable()
intCount = 0
myOffset = 1
For i = 1 To Len(strTable)
    intCellStartPos = InStr(myOffset, strTable, "")
    If intCellStartPos > 0 Then
        myOffset = intCellStartPos + 1
        intCellEndPos = InStr(intCellStartPos, strTable, "")
        strRow = Mid(strTable, intCellStartPos, (intCellEndPos + 4) - (intCellStartPos - 1))
        hrefPos = InStr(strRow, "HREF=")
        intStartTagPos = InStr(hrefPos, strRow, ">")
        intEndTagPos = InStr(intStartTagPos, strRow, "")
        strLinkText = Mid(strRow, intStartTagPos + 1, intEndTagPos - (intStartTagPos + 1))
        intCount = intCount + 1
        ReDim Preserve aryTable(2, intCount)
        aryTable(1, intCount) = strLinkText
        aryTable(2, intCount) = strRow
    Else
        Exit For
    End If
Next

' Sort the Array
MyQuickSort_Single aryTable(), 1, UBound(aryTable(), 2), 1, True

strTable = ""
For i = 1 To UBound(aryTable(), 2)
    strTable = strTable & aryTable(2, i)
Next

Selection.Delete
Selection.TypeText strTable

BYE:
Application.StatusBar = ""
Application.ScreenUpdating = True
Application.ScreenRefresh
MacroEndTime = Now
ElapsedTime = CrunchTime(MacroStartTime, MacroEndTime)
MsgBox "HTML Sorted." & vbCrLf & vbCrLf & _
            ElapsedTime, vbOKOnly, " PROCESS COMPLETE!"
FINAL_BYE:
Exit Sub
ERROR_HANDLER:
Btn = MyErrorHandler(Err.Source, Err.Number, Err.Description)
End Sub

' Function to display Error messages
Private Function MyErrorHandler(ErrSource, ErrNum, ErrDesc)
MsgBox "Following ERROR has been detected:" & vbCrLf & vbCrLf + _
            "Error Number = " & Str(ErrNum) & vbCrLf & vbCrLf & _
            "Error Description = " & ErrDesc, vbExclamation + vbOKOnly, _
            " " & ErrSource & " -- ERROR!"
End Function

' Function to trim strings
Private Function TrimSelection(ByVal Temp As String)
Dim L As String
Dim R As String
Sp = Chr(32)
Rtn = Chr(13)
Tb = Chr(9)
Rtt = Chr(10)
Ltb = Chr(7)
TRIM_LOOP:
L = Left(Temp, 1)
R = Right(Temp, 1)
If (L = Sp) Or (L = Rtn) Or (L = Tb) Or (L = Rtt) Or (L = Ltb) Then
    Temp = Right(Temp, Len(Temp) - 1)
    GoTo TRIM_LOOP
ElseIf (R = Sp) Or (R = Rtn) Or (R = Tb) Or (R = Rtt) Or (R = Ltb) Then
    Temp = Left(Temp, Len(Temp) - 1)
    GoTo TRIM_LOOP
End If
TrimSelection = Temp
End Function

' Function to calculate elapsed time
Private Function CrunchTime(StartTime, EndTime)
ElapsedSeconds = DateDiff("s", StartTime, EndTime)
If ElapsedSeconds > 60 Then
    ElapsedSeconds = ElapsedSeconds Mod 60
End If
ElapsedMinutes = DateDiff("n", StartTime, EndTime)
If ElapsedMinutes = 0 Then
    CrunchTime = "Elapsed time was " & ElapsedSeconds & " seconds!"
    Exit Function
Else
    CrunchTime = "Elapsed time was " & ElapsedMinutes & " minutes and " & ElapsedSeconds & " seconds!"
    Exit Function
End If
End Function

' Multidimensional Array sorted on a single dimensions (can be either 0 or 1 based)
Private Sub MyQuickSort_Single(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long, _
        ByVal PrimeSort As Integer, ByVal Ascending As Boolean)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Dim TempArray() As Variant
ReDim TempArray(UBound(SortArray, 1))
Low = First
High = Last
List_Separator1 = SortArray(PrimeSort, (First + Last) / 2)
Do
    If Ascending = True Then
        Do While (SortArray(PrimeSort, Low) < List_Separator1)
            Low = Low + 1
        Loop
        Do While (SortArray(PrimeSort, High) > List_Separator1)
            High = High - 1
        Loop
    Else
        Do While (SortArray(PrimeSort, Low) > List_Separator1)
            Low = Low + 1
        Loop
        Do While (SortArray(PrimeSort, High) < List_Separator1)
            High = High - 1
        Loop
    End If
    If (Low <= High) Then
        For i = LBound(SortArray, 1) To UBound(SortArray, 1)
            TempArray(i) = SortArray(i, Low)
        Next
        For i = LBound(SortArray, 1) To UBound(SortArray, 1)
            SortArray(i, Low) = SortArray(i, High)
        Next
        For i = LBound(SortArray, 1) To UBound(SortArray, 1)
            SortArray(i, High) = TempArray(i)
        Next
        Low = Low + 1
        High = High - 1
    End If
Loop While (Low <= High)
If (First < High) Then MyQuickSort_Single SortArray, First, High, PrimeSort, Ascending
If (Low < Last) Then MyQuickSort_Single SortArray, Low, Last, PrimeSort, Ascending
End Sub



Note to Webmaster