' 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, "
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