Необходимо расширить множественный поиск и замену в MS Word из списка в MS Excel, чтобы заменить текст с гиперссылкой и исправить ошибку.

Question

У меня большой файл Word, который ссылается на несколько Вопросов по всему. У меня также есть файл Excel, в котором перечислены все вопросы # в столбце A, а в столбце B есть список актуальных вопросов, которые также являются гиперссылками. Я хотел бы заменить каждый вопрос # в документе Word соответствующим вопросом с гиперссылкой в ​​столбце B электронной таблицы.

Я пытался использовать макрос в вопросе StackOverflow Многократное нахождение и замена в MS Word из списка в MS Excel , но я получаю

Ошибка времени выполнения '1004': невозможно получить свойство Special Cells класса Range.

Я не уверен, что это значит или как это исправить. Также я предполагаю, что этот макрос нуждается в корректировке, чтобы можно было вставлять гиперссылочный текст в столбце B.

Спасибо за любую помощь! PS Мы делали это вручную и ежегодно для 4-х руководств с более чем 100 вопросами в каждом руководстве в течение последних 15 лет. Я так хочу выяснить способ автоматизации !!

Answer 1

На основе ваших образцов файлов:

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

Answer 2

Проблема с кодом в ссылке в том, что он написан для позднего связывания, но тем не менее использует именованную константу 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» превратит ваш вопросы в гиперссылки.

Макрос предполагает, что вы используете книгу Excel с именем QuestionLinks.xlsx, хранящуюся в папке «Документы», а список вопросов и гиперссылок находится в столбцах A и B, соответственно, в ' Лист1' .