Add plain text to Hyperlink via VBA

[Goshute]

I have been asked as a subcontractor to extract Vendor IDs from a public list of client entity vendors and do some stuff with them. (It's a very large entity and nobody within the client team I'm working with knows who manages the source data, so I'm shortcutting the detective process). The list is simply copied from the website with click mousedrag, and pastes into Word in a simple non-table line by line format, with additional breaks at each new letter of the alphabet. While the macro works to get the Vendor ID, due to my lack of skill with Word VBA the code returns this odd phenomenon where after the first Vendor ID in each alphabet letter group the subsequent VIDs in the alpha letter display as if they are part of the hyperlink. Can someone advise? All code improvements are welcome, and yes I'm hoping to provide the final macro and technique back to the client team for their future use.

Code: Select all

Sub GetWriteVID()
' Place VID next to vendor name

  Dim hloLink As Hyperlink
  Dim strAllAddressText As String, strVID As String
  Dim lngVIDStartPos As Long
  Dim boolHasVID As Boolean

  With ActiveDocument
    .Paragraphs.TabStops.Add Position:=InchesToPoints(3.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
    For Each hloLink In .Hyperlinks
      On Error GoTo ERRHANDLER
      strAllAddressText = hloLink.Address
      lngVIDStartPos = InStr(7, strAllAddressText, "=u", vbTextCompare) + 1
      boolHasVID = CBool(lngVIDStartPos - 1)
      If boolHasVID Then
        strVID = Mid(strAllAddressText, lngVIDStartPos, 8)
        hloLink.Range.InsertAfter vbTab & strVID
      End If
    Next
  End With
ERRHANDLER::
    If CBool(Err.Number) Then Debug.Print hloLink.Address & vbTab & Err.Number & vbTab & Err.Description
End Sub

Thanks for any help, and again yes, I will make money from this. But that's true for all of us trying to resolve work problems, right?

[HansV]

Could you provide a small sample document (without sensitive information)?

[Goshute]

Hans, thank you, hope I didn't leave any private information in here.

ELAddTextMacroSample.docm

[Rudi]

Not my field of expertise, but I can contribute what seems to work for me...
It's seems just a formatting issue; the line adopts the formatting from the beginning of the line.

Add the the two selection statements as in the code below...

Code: Select all

  With ActiveDocument
    Selection.WholeStory
    Selection.Font.Reset
    .Paragraphs.TabStops.Add Position:=InchesToPoints(3.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces

[Rudi]

Here is a better attempt that does not delete the original formatting of the document.

Code: Select all

Sub GetWriteUID()
' Place UID next to name

Dim hloLink As Hyperlink
Dim strAllAddressText As String, strUID As String
Dim lngUIDStartPos As Long
Dim boolHasUID As Boolean
Dim iLink As Long

    Application.ScreenUpdating = False
    With ActiveDocument
        .Paragraphs.TabStops.Add Position:=InchesToPoints(3.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        For Each hloLink In .Hyperlinks
            On Error GoTo ERRHANDLER
            strAllAddressText = hloLink.Address
            lngUIDStartPos = InStr(7, strAllAddressText, "=u", vbTextCompare) + 1
            boolHasUID = CBool(lngUIDStartPos - 1)
            If boolHasUID Then
                strUID = Mid(strAllAddressText, lngUIDStartPos, 8)
                hloLink.Range.InsertAfter vbTab & strUID
                hloLink.Range.Select
                Selection.MoveRight Unit:=wdCharacter, Count:=1
                Selection.EndKey Unit:=wdLine, Extend:=wdExtend
                Selection.Font.Reset
            End If
        Next
        Selection.HomeKey Unit:=wdStory
    End With
ERRHANDLER::
    If CBool(Err.Number) Then Debug.Print hloLink.Address & vbTab & Err.Number & vbTab & Err.Description
    Application.ScreenUpdating = True
End Sub

[Goshute]

Rudi, thanks for your help. In the end I decided to bulk correct the formatting with VBA Find and Replace, but I appreciate your effort.

Final Code:

Code: Select all

Sub GetWriteUID()
' Place UID next to name, find-&-replace formatting for clarity

  Dim hloLink As Hyperlink
  Dim strAllAddressText As String, strUID As String
  Dim lngUIDStartPos As Long, lngC As Long
  Dim boolHasUID As Boolean

  Application.ScreenUpdating = False
  With ActiveDocument
    .Paragraphs.TabStops.Add Position:=InchesToPoints(3.5), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
    For lngC = .InlineShapes.Count To 1 Step -1
      .InlineShapes(lngC).Delete
    Next lngC
    For Each hloLink In .Hyperlinks
      On Error GoTo ERRHANDLER
      strAllAddressText = hloLink.Address
      lngUIDStartPos = InStr(7, strAllAddressText, "=u", vbTextCompare) + 1
      boolHasUID = CBool(lngUIDStartPos - 1)
      If boolHasUID Then
        strUID = Mid(strAllAddressText, lngUIDStartPos, 8)
        hloLink.Range.InsertAfter vbTab & strUID
      End If
    Next
    With .Range.Find
      .Text = "^tu^?^?^?^?^?^?^?"
      .Font.Underline = wdUnderlineSingle
      With .Replacement.Font
        .Underline = wdUnderlineNone
        .ColorIndex = wdAuto
      End With
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .Execute Replace:=wdReplaceAll
    End With
  End With

ERRHANDLER::
    If CBool(Err.Number) Then Debug.Print hloLink.Address & vbTab & Err.Number & vbTab & Err.Description
  Application.ScreenUpdating = True
End Sub

[Rudi]

The method is irrespective as long as the result is what you need.