How to work with selection - vba

Question

I am trying to convert perfectly working macro to hyperlink with activedoccument.range to selection.range.
code is
With Selection.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "String String1"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
strtxt = Split(.Text, " ")(1)
strtxt = Right(strtxt, 2) & "/" & Left(strtxt, 4) & "/" & Mid(strtxt, 8, 2) & "/" & Mid(strtxt, 5, 3)
.Hyperlinks.Add Anchor:=.Duplicate, Address:="Address" & strtxt & "/0.pdf", TextToDisplay:=.Text
.End = .Fields(1).Result.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
How to collapse correctly to make this work. Currently it hyperlinks all in the doccument instead selection.

Answer 1

As far as I can tell, the problem is basically that the found range's end needs to be increased by 1 when the hyperlink is inserted. But I believe you also have to check that you have not gone past the original Selection.Range end, so you need an additional test.
This seemed OK in Tables, but (a) I am currently testing in Mac Word 2011, which may well be different, and (b), if you actually select a column or noncontiguous ranges, you would have to work a lot harder to make the changes only in the selection (because of well-known lack of support for such selections).
Sub fandr()
Const strText As String = "String String1"
Dim dr As Word.Range
Dim sr As Word.Range
Set sr = Selection.Range
'Debug.Print sr.Start, sr.End
Set dr = sr.Duplicate
' Try to deal with the problem where Find fails to find
' the Find text if it is exactly the same as the selection
sr.Collapse wdCollapseStart
With sr.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
Do While .Execute(Replace:=False)
If sr.InRange(dr) Then
'Debug.Print sr.Start, sr.End, dr.Start, dr.End
strtxt = Split(.Text, " ")(1)
strtxt = Right(strtxt, 2) & "/" & Left(strtxt, 4) & "/" & Mid(strtxt, 8, 2) & "/" & Mid(strtxt, 5, 3)
sr.Hyperlinks.Add Anchor:=sr, Address:="Address" & strtxt & "/0.pdf", TextToDisplay:=.Text
sr.Collapse wdCollapseEnd
sr.End = sr.End + 1
sr.Start = sr.End
'Debug.Print sr.Start, sr.End, dr.Start, dr.End
Else
Exit Do
End If
Loop
End With
Set sr = Nothing
Set dr = Nothing
End Sub

Answer 2

So I have changed a few things. Somehow the Range was getting messed up after adding the HyperLink. so I just reset the SearchRange after adding the hyperlink.
This will work perfectly if the selection is not part of a Table I have added some checks to see if its in side the table but dont have time now to complete the cell shift.
Sub SearchTextAddHyperLink()
Dim SearchRange As Range
Dim OriginalRange As Range
Dim FoundRange As Range
Set SearchRange = Selection.Range
Set OriginalRange = Selection.Range
Dim strtxt As String
Dim SearchText As String
Dim CellPosition As String
SearchText = "String String1"
With SearchRange
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = SearchText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
'.Select
If .Find.Found = True Then
Set FoundRange = SearchRange
FoundRange.Select
strtxt = Split(.Text, " ")(1)
strtxt = Right(strtxt, 2) & "/" & Left(strtxt, 4) & "/" & Mid(strtxt, 8, 2) & "/" & Mid(strtxt, 5, 3)
.Hyperlinks.Add Anchor:=.Duplicate, Address:="Address" & strtxt & "/0.pdf", TextToDisplay:=.Text
If Not FoundRange.Information(wdWithInTable) Then
'Resetting the SearchRange for outside a table
'For some reason the Hyperlink messes up the Range
'Len(SearchText) + 1 just caters for the changing the Search Text
'and adding an additional character to move passed the hyperlink
SearchRange.Start = FoundRange.End + Len(SearchText) + 1
SearchRange.End = OriginalRange.End
Else
'Resetting the SearchRange for inside a table
'Need to then be clever with determinign which cell you are in and then moving to the next cell
'SearchRange.Start = FoundRange.End 'Len(SearchText) + 1
'SearchRange.End = OriginalRange.End
End If
End If
'Just to check the SearchRange
SearchRange.Select
Loop
End With
End Sub
NOTE: Also, remember to also Dim all your variables going forward.