需要从 MS Excel 的列表中展开 MS Word 中的多个查找和替换以替换带有超链接的文本并修复错误

Posted 2023-03-11

【中文标题】需要从 MS Excel 的列表中展开 MS Word 中的多个查找和替换以替换带有超链接的文本并修复错误

【英文标题】：Need to expand Multiple find and replace in MS Word from a list in MS Excel to replace text w hyperlink and fix error

【发布时间】：2020-06-30 04:29:47

【问题描述】：

我有一个大的 Word 文件，它自始至终引用了多个问题#。 我还有一个 Excel 文件，其中列出了 A 列中的所有问题 #，在 B 列中，还有一个实际问题列表，这些问题也是超链接。 我想将 Word 文档中的每个问题 # 替换为电子表格 B 列中相应的超链接问题。

我尝试在 *** 问题 Multiple find and replace in MS Word from a list in MS Excel 中使用宏，但得到了

运行时错误“1004”：无法获取 范围类。

我不确定这意味着什么或如何解决它。 另外我猜这个宏需要调整才能插入 B 列中的超链接文本。

感谢您的帮助！ PS 在过去的 15 年里，我们一直在手动和每年为 4 个指南进行此操作，每个指南中有超过 100 个问题。我很想找到一种自动化的方法！

【问题讨论】：

了解您的 Word 文件是什么样子会很有用 - 您可以添加屏幕截图吗？

我想将问题 14、15 和 4 分别替换为哪些证明是可选的？、我如何发送 DTA 我的文件？以及 SSI 收件人的 Bay State CAP 是什么？，分别也是超链接但不会粘贴到 *** 评论框中。 word doc 的图片在 Dropbox dropbox.com/s/tzsktpsrnu6ghrr/…

【参考方案1】：

链接中代码的问题在于它是为后期绑定而编写的，但仍然使用了一个命名的 Excel 常量。将“xlCellTypeLastCell”更改为“11”。

由于您想要超链接问题，请尝试以下方式：

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

运行“HyperlinkQuestions”宏会将您的问题变成超链接。

该宏假定您正在使用存储在“文档”文件夹中的名为“QuestionLinks.xlsx”的 Excel 工作簿，并且问题和超链接列表分别位于“Sheet1”的 A 列和 B 列中。

【讨论】：

这样做运行时错误'6028'：无法删除范围。

我遇到的另一个问题是我打开了 Word，我运行宏，然后在后台不可见 Excel 文件打开并保持打开状态。如果我找到它，该文件是只读的。这很烦人，但如果我只能让这个查找和替换的东西工作，我可以处理它。

«在幕后不可见 Excel 文件已打开并保持打开状态» 很可能是因为宏正在崩溃。在 'Set xlApp' 行之后插入 'xlApp.Visible = True' 将使其保持可见，因此您可以在宏失败时终止 Excel 会话。

«运行时错误 '6028'» 很可能是因为代码找到了无法替换的内容。您的文件是否应用了任何形式的保护？无论如何，链接中的代码都不会插入超链接。试试我更新的答案中的代码。

谢谢！这是有效的 - 除了问题 # 是超链接的，但问题 4 没有替换为文本“SSI 接受者的 Bay State CAP 是什么？”新文本应替换并链接。要解决的问题是更换每个例如问题 4，带有“SSI 接受者的 Bay State CAP 是什么？”新文本应链接到 masslegalhelp.org/income-benefits/food-stamps/advocacy-guide/… 。这个脚本让我们尽可能地链接问题#s，但不会用链接文本替换问题#s。感谢您整理的内容。

【参考方案2】：

根据您的示例文件：

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