WORD 2010 Sort .find.found selection - Please Help

[pk247]

Hi Everyone,

I hope you can help me with the final piece to this puzzle. I came up with following code which lets me enter a search critera string for a tag which is in ~200 page Word doc in square brackets and then display all records in a textbox. The one thing I really need this to do is sort my tags. To illustrate, I run the code and type "ABC-C-" and the tag finder returns as follows:

[ABC-C-1]
[ABC-C-2]
[ABC-C-6]
[ABC-C-4]
[ABC-C-7]
[ABC-C-8]
[ABC-C-5]
[ABC-C-3]

...This is the order in which the tags were placed in the Word Doc.

Now it is easy to see the highest tag number is "8" BUT if I have made 120 tags for ABC-C- and they are dispersed throughout my document then it takes me a lot of time to look for the highest number. You might be thinking copy and paste this to excel then sort but I know Word has a Sort feature and I was really hoping I could add this into my code below.

Any help or pointers in the right direction would be much appreciated!

Thanks!

Paul, Ireland


Sub TAG_FINDER()

Dim msg As String
Dim EnterTag As String
Dim rng As Range


On Error GoTo ErrMsg

With Selection

.HomeKey wdStory

With .Find

EnterTag = InputBox("Enter the Tag that you want to find. Case-sensitive" _
, "Find Tag(s)")

.ClearFormatting
.Format = False
.text = "\[" & EnterTag & "*\]"
.Replacement.text = ""
.MatchWildcards = True
.Forward = True
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.Execute

End With

Do
msg = msg & Selection & vbNewLine
.Find.Execute
'.SortAscending ----THIS is where i want the selection to be sorted top-down
Loop While .Find.found

End With

'Display results in scrollable textbox

With UserForm2
.TextBox1 = msg
.Show
End With

Exit Sub

ErrMsg:
MsgBox ("Please try again") & vbNewLine & vbNewLine & ("Text is Case-Sensitive!"), , "Tag Not Found!"

End Sub

[gmayor]

If you write the values to an array, you can quickly sort the array e.g.


Option Explicit

Sub TAG_FINDER()

Dim msg As String
Dim Coll As New Collection
Dim arr() As Variant
Dim i As Long
Dim EnterTag As String
Dim strFind As String
Dim oRng As Range
On Error GoTo ErrMsg
Set oRng = ActiveDocument.Range
EnterTag = InputBox("Enter the Tag that you want to find. Case-sensitive" _
, "Find Tag(s)")
strFind = "\[" & EnterTag & "*\]"
With oRng.Find
Do While .Execute(FindText:=strFind, MatchWildcards:=True)
Coll.Add oRng.Text
Loop
End With

arr = toArray(Coll)
QuickSort arr, LBound(arr), UBound(arr)
For i = LBound(arr) To UBound(arr)
msg = msg & arr(i) & vbNewLine
Next i
'Display results in scrollable textbox

With UserForm2
.TextBox1 = msg
.Show
End With

'MsgBox msg
Exit Sub

ErrMsg:
MsgBox ("Please try again") & vbNewLine & vbNewLine & ("Text is Case-Sensitive!"), , "Tag Not Found!"

End Sub

Private Function toArray(ByVal Coll As Collection) As Variant
Dim arr() As Variant
Dim i As Long
ReDim arr(1 To Coll.Count) As Variant
For i = 1 To Coll.Count
arr(i) = Coll(i)
Next
toArray = arr
lbl_Exit:
Exit Function
End Function

Private Sub QuickSort(vArray As Variant, lng_Low As Long, lng_High As Long)
Dim vPivot As Variant
Dim vTmp_Swap As Variant
Dim tmp_Low As Long
Dim tmp_High As Long
tmp_Low = lng_Low
tmp_High = lng_High
vPivot = vArray((lng_Low + lng_High) \ 2)
While (tmp_Low <= tmp_High)
While (vArray(tmp_Low) < vPivot And tmp_Low < lng_High)
tmp_Low = tmp_Low + 1
Wend
While (vPivot < vArray(tmp_High) And tmp_High > lng_Low)
tmp_High = tmp_High - 1
Wend
If (tmp_Low <= tmp_High) Then
vTmp_Swap = vArray(tmp_Low)
vArray(tmp_Low) = vArray(tmp_High)
vArray(tmp_High) = vTmp_Swap
tmp_Low = tmp_Low + 1
tmp_High = tmp_High - 1
End If
Wend
If (lng_Low < tmp_High) Then QuickSort vArray, lng_Low, tmp_High
If (tmp_Low < lng_High) Then QuickSort vArray, tmp_Low, lng_High
lbl_Exit:
Exit Sub
End Sub

[pk247]

Thank you so much for taking the time to give me this Graham! It worked perfect for ABC-C-1 to ABC-C-9 but then I tested it with ABC-C-1 up to ABC-C-200 in a test document and the numbers were ordered like:


[ABC-C-100]
[ABC-C-101]
[ABC-C-102]
[ABC-C-103]
[ABC-C-104]
[ABC-C-105]
[ABC-C-106]
[ABC-C-107]
[ABC-C-108]
[ABC-C-109]
[ABC-C-10]
[ABC-C-110]
[ABC-C-111]
[ABC-C-112]
So it looks like all the 1's get grouped, then all the 2's, then 3's etc.

I've had this happen in excel many times and figured out ways to resolve it but your code is way beyond my ability to edit unfortunately. Is there maybe a quick edit you could make to sort the array by the integers in the far right of the "arr" so that 1 to 200 are ordered numerically?

The structure will always be [ABC-C-1], [ABC-C-11], [ABC-C-111] i.e. the integers will be to the far right, after a hyphen, and beside the bracket "]"

I hope this reads okay and I hope this isn't too much trouble to ask. Thank you so much for helping me!

Paul, Ireland

[gmayor]

OK, as you gathered the sort was alphabetical. If you want a numeric sort then lose the QuickSort sub and replace it with the following.


Private Sub BubbleSort(List() As Variant)
Dim lng_First As Long, lng_Last As Long
Dim i As Integer, j As Integer
Dim vTemp As Variant
lng_First = LBound(List)
lng_Last = UBound(List)
For i = lng_First To lng_Last - 1
For j = i + 1 To lng_Last
If ExtractDigits(CStr(List(i))) > ExtractDigits(CStr(List(j))) Then
vTemp = List(j)
List(j) = List(i)
List(i) = vTemp
End If
Next j
Next i
lbl_Exit:
Exit Sub
End Sub

Private Function ExtractDigits(strText As String) As String
Dim i As Integer
ExtractDigits = ""
For i = 1 To Len(strText)
If Mid(strText, i, 1) >= "0" And _
Mid(strText, i, 1) <= "9" Then
ExtractDigits = ExtractDigits + Mid(strText, i, 1)
End If
Next
lbl_Exit:
Exit Function
End Function


Change the line

QuickSort arr, LBound(arr), UBound(arr)to
BubbleSort arr

This will give you:

[ABC-C-10]
[ABC-C-100]
[ABC-C-101]
[ABC-C-102]
[ABC-C-103]
[ABC-C-104]
[ABC-C-105]
[ABC-C-106]
[ABC-C-107]
[ABC-C-108]
[ABC-C-109]
[ABC-C-110]
[ABC-C-111]
[ABC-C-112]

[gmayor]

On reflection I don't think that will work either. Let me think about it a bit longer :(

[gmayor]

OK I spotted the deliberate mistake :banghead:
Change the line

If ExtractDigits(CStr(List(i))) > ExtractDigits(CStr(List(j))) Then
to

If Val(ExtractDigits(CStr(List(i)))) > Val(ExtractDigits(CStr(List(j)))) Thenwhich will give you
[ABC-C-1]
[ABC-C-2]
[ABC-C-3]
[ABC-C-4]
[ABC-C-5]
[ABC-C-6]
[ABC-C-7]
[ABC-C-8]
[ABC-C-9]
[ABC-C-10]
[ABC-C-100]
[ABC-C-101]
[ABC-C-102]
[ABC-C-103]
[ABC-C-104]
[ABC-C-105]
[ABC-C-106]
[ABC-C-107]
[ABC-C-108]
[ABC-C-109]
[ABC-C-110]
[ABC-C-111]
[ABC-C-112]
[ABC-C-1000]

[pk247]

Graham Mayor, you sir, are the Mozart of VBA!

It works perfectly :rotlaugh: - I can't thank you enough because that would have taken me a week to figure out!

For anyone else who uses tags in word docs and ever stumbles across this thread here is the final working code that numerically sorts your search:


Option Explicit

Sub z_TAG_FINDER()

Dim msg As String
Dim Coll As New Collection
Dim arr() As Variant
Dim i As Long
Dim EnterTag As String
Dim strFind As String
Dim oRng As Range

On Error GoTo ErrMsg
Set oRng = ActiveDocument.Range
EnterTag = InputBox("Enter the Tag that you want to find. Case-sensitive" _
, "Find Tag(s)")
strFind = "\[" & EnterTag & "*\]"
With oRng.Find
Do While .Execute(FindText:=strFind, MatchWildcards:=True)
Coll.Add oRng.text
Loop
End With

arr = toArray(Coll)
BubbleSort arr
For i = LBound(arr) To UBound(arr)
msg = msg & arr(i) & vbNewLine
Next i

'Display results in scrollable textbox
With UserForm2
.TextBox1 = msg
.Show
End With

Exit Sub

ErrMsg:
MsgBox ("Please try again") & vbNewLine & vbNewLine & ("Text is Case-Sensitive!"), , "Tag Not Found!"

End Sub

Private Function toArray(ByVal Coll As Collection) As Variant
Dim arr() As Variant
Dim i As Long
ReDim arr(1 To Coll.Count) As Variant
For i = 1 To Coll.Count
arr(i) = Coll(i)
Next
toArray = arr
lbl_Exit:
Exit Function
End Function

Private Sub BubbleSort(List() As Variant)
Dim lng_First As Long, lng_Last As Long
Dim i As Integer, j As Integer
Dim vTemp As Variant
lng_First = LBound(List)
lng_Last = UBound(List)
For i = lng_First To lng_Last - 1
For j = i + 1 To lng_Last
If Val(ExtractDigits(CStr(List(i)))) > Val(ExtractDigits(CStr(List(j)))) Then
vTemp = List(j)
List(j) = List(i)
List(i) = vTemp
End If
Next j
Next i
lbl_Exit:
Exit Sub
End Sub

Private Function ExtractDigits(strText As String) As String
Dim i As Integer
ExtractDigits = ""
For i = 1 To Len(strText)
If Mid(strText, i, 1) >= "0" And _
Mid(strText, i, 1) <= "9" Then
ExtractDigits = ExtractDigits + Mid(strText, i, 1)
End If
Next
lbl_Exit:
Exit Function
End Function

[pk247]

Sorry to bother you Graham but I was hoping you could maybe help me with one final request on this please? If I do the following:

strFind = "\[??" & "-C-" & "*\]"

and remove the code about EnterTag then all the two letters in the .find will show up. I'm having difficulty trying to code it so that ?,??,???,???? are all picked up. I think it would need to be in an array of some sort but no matter how I try it doesn't work. I have checked your website for ideas and see kind of how it works but I can't get it to work in this code. Would you be able to help at all please?

If this doesn't make sense then hopefully this will:

desired code will return all instances, in numerical order e.g.

[A-C-01]
[A-C-02]
[AA-C-01]
[AA-C-02]
[AB-C-01]
[AB-C-02]
[AB-C-03]
[AAC-C-01]
[AAC-C-02]
[AAC-C-03]
...

Using * won't work because there are other random instances of [] in the document I need to hone in on format: [???-C-##]

Please let me know if I need to explain this further but hopefully you can see what I'm getting at?

Thanks!!!

[pk247]

Sorry Graham, I think I solved it myself:

strFind = "\[" & "[A-Z.]{1,}-C-" & "*\]"

This returns exactly what I was looking for :)

All thanks to your NATO code here: http://www.gmayor.com/word_vba_examples_2.htm

Thanks again!!