Need to expand Multiple find and replace in MS Word from a list in MS Excel to replace text w hyperlink and fix error

问题

I have a large Word file that refers to multiple Question #s throughout. I also have an Excel file that lists all the Question #s in Column A and in Column B there is a list of actual questions that are also hyperlinks. I would like to replace every question # in the Word document with the corresponding hyperlinked question in Column B of the spreadsheet.

I tried to use the macro in the StackOverflow question Multiple find and replace in MS Word from a list in MS Excel, but I get the

Run-time error '1004': Unable to get the Special Cells property of the Range class.

I am not sure what this means or how to fix it. Also I am guessing this macro needs adjusting to be able to insert the hyperlinked text that is in Column B.

Thanks for any help! PS We have been doing this manually and annually for 4 guides with over 100 questions in each guide for the past 15 years. I so want to figure out a way to automate!!

回答1:

Based on your sample files:

Sub ReplaceInWordWithLinks()

    Dim wsName As String, ws As Worksheet, oWord As Object, oDoc As Object
    Dim cQNum As Range, qText As String, qContent As String, qLink As String
    Dim lnk As Hyperlink

    wsName = "TestLinkswLinks"

    Set ws = ThisWorkbook.Worksheets(wsName)

    Set oWord = GetObject(, "Word.application") 'get the open Word application
    Set oDoc = oWord.activedocument

    Set cQNum = ws.Range("A1") 'first question

    'do while cell is not blank
    Do While Len(cQNum.Value) > 0

        qText = Trim(cQNum.Value)
        'add trailing period if missing
        If Right(qText, 1) <> "." Then qText = qText & "."
        qContent = cQNum.Offset(0, 1).Value
        'is there an associated link?
        Set lnk = Nothing
        qLink = ""
        On Error Resume Next
        Set lnk = cQNum.Offset(0, 1).Hyperlinks(1)
        On Error GoTo 0
        If Not lnk Is Nothing Then qLink = lnk.Address

        Debug.Print qText, qContent, qLink

        ReplaceQuestionWithLink oDoc, qText, qContent, qLink

        Set cQNum = cQNum.Offset(1, 0) 'next question
    Loop

End Sub

'Replace all occurences of question with content and a link
'  qText = 'Question 3.' (eg)
Function ReplaceQuestionWithLink(doc As Object, qText As String, _
                                 qContent As String, qLink As String)
    Dim rng As Object

    Set rng = doc.Range

    ResetFindParameters rng 'reset Find to defaults

    With rng.Find
        .Text = qText
        Do While .Execute
            rng.Select
            doc.Parent.ActiveWindow.ScrollIntoView rng, True
            rng.Text = qContent             'replace text
            If Len(qLink) > 0 Then
                doc.Hyperlinks.Add rng, qLink   'add link if present
            End If
        Loop
    End With

End Function


Sub ResetFindParameters(oRng As Object)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = 1 'wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = True '<<
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
End Sub

回答2:

The problem with the code in the link is that it's written for late binding but nevertheless uses a named Excel constant. Change 'xlCellTypeLastCell' to '11'.

Since you're wanting to hyperlink the questions, try something along the lines of:

Sub HyperlinkQuestions()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, r As Long
Dim StrFnd As String, StrHLnk As String, StrHTxt As String
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\QuestionLinks.xlsx"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets("Sheet1")
      'Process the F/R data
      For r = 2 To .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        If Trim(.Range("A" & r)) <> vbNullString Then
          StrFnd = .Range("A" & r).Text
          With .Range("B" & r)
            If .Hyperlinks.Count = 1 Then
              StrHLnk = .Hyperlinks(1).Address
              StrHTxt = .Hyperlinks(1).TextToDisplay
            Else
              StrHLnk = .Text
              StrHTxt = .Text
            End If
          End With
          Call LinkQuestion(StrFnd, StrHLnk, StrHTxt)
        End If
      Next
    End With
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub

Sub LinkQuestion(StrFnd As String, StrHLnk As String, StrHTxt As String)
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = StrFnd
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = True
    .MatchWholeWord = True
    .Execute
  End With
  Do While .Find.Found
    .Hyperlinks.Add .Duplicate, StrHLnk, , , StrHTxt
    .Start = .Hyperlinks(1).Range.End
    .Find.Execute
  Loop
End With
End Sub

Running the 'HyperlinkQuestions' macro will turn your questions into hyperlinks.

The macro assumes you're using an Excel workbook named 'QuestionLinks.xlsx' stored in your 'Documents' folder and the Question & Hyperlink list are in Columns A & B, respectively, of 'Sheet1'.

来源：https://stackoverflow.com/questions/60750388/need-to-expand-multiple-find-and-replace-in-ms-word-from-a-list-in-ms-excel-to-r