Question

我编写了以下宏来扫描PPT文档，并在引用的Excel工作表上查找/替换一系列单词。这或多或少完全符合我的喜好。我现在正尝试将其设置为与Word文档一起使用，但是我对“Word”语法有些麻烦，因为它有点不同。任何人都可以帮我开始吗？

也许还有更好的方法 - 我以这种方式编写它，因为它允许任何用户打开Excel文档，单击按钮，提取文档并让宏执行其工作。

Sub QE_US()
    'VARIABLES
    Dim PowerPointApp As PowerPoint.Application
    Dim myPresentation As PowerPoint.presentation
    Dim fnd As Variant
    Dim rplc As Variant
    Dim FindArray As Variant
    Dim ReplaceArray As Variant
    Dim TxtRng As PowerPoint.TextRange
    Dim TmpRng As PowerPoint.TextRange
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim objPPT As Object

    'PROMPT USER TO OPEN POWERPOINT DOC
    Set objPPT = CreateObject("PowerPoint.Application")
    objPPT.Visible = True

    AppActivate Application.Caption
    strFileToOpen = Application.GetOpenFilename _
    (Title:="Please Choose PowerPoint for QE - US Conversion")

    If strFileToOpen = False Then
        MsgBox "No file selected.", vbExclamation, "Sorry!"
        GoTo Ending
    End If

    objPPT.Presentations.Open Filename:=strFileToOpen

    'PULLING ARRAY FROM EXCEL
    FindArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("C3:C64"))
    ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("B3:B64"))

    'LOOP THROUGH EACH SLIDE
    For Each sld In objPPT.ActivePresentation.Slides
        objPPT.Activate
        objPPT.ActiveWindow.View.GotoSlide sld.SlideIndex
        For y = LBound(FindArray) To UBound(FindArray)
            For Each shp In sld.Shapes
                fnd = FindArray(y)
                rplc = ReplaceArray(y)

                If shp.HasTextFrame Then
                    If shp.TextFrame.HasText Then
                        Set TxtRng = shp.TextFrame.TextRange.Find(fnd, 0, True, WholeWords:=msoFalse)
                        If TxtRng Is Nothing Then GoTo NextTxtRng
                        TxtRng.Select

                        AppActivate Application.Caption
                        If MsgBox("Replace " & fnd & " with " & rplc & "?", vbYesNo + vbSystemModal) = vbYes _
                        Then Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
                        ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=True)
                    End If
                End If

                'REPLACE OTHER INSTANCES
                Do While Not TmpRng Is Nothing
                    Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
                    ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=False)
                Loop

                'IF TEXT RANGE IS NOTHING (NO VALUE FOUND)
NextTxtRng:
            Next shp
        Next y
    Next sld

    AppActivate Application.Caption
    MsgBox "QE replaced with US"

    'IF NO POWERPOINT SELECTED
Ending:
End Sub

我想它可以简化一点，因为它不再通过幻灯片，形状等查看，只能扫描整个文档？

Answer 1

使用quite a bit of bikeshedding作为起点：

{{1}}

Answer 2

感谢您指点我正确的方向。以下是生成的工作代码。

Sub US_QE_Word()

'VARIABLES
Dim rngXL As Range
Dim x As Range
Dim strFind As String
Dim strReplace As String
Dim rngStory As Object
Dim lngJunk As Long
Dim objWord As Object

'PROMPT USER TO OPEN DOC
Set objWord = CreateObject("Word.Application")
objWord.Visible = True

AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose File for US - QE Conversion")

If strFileToOpen = False Then
    MsgBox "No file selected."
    GoTo Ending
End If

objWord.Documents.Open Filename:=strFileToOpen

'FIND/REPLACE

objWord.ActiveDocument.TrackRevisions = True
Set rngXL = ThisWorkbook.Worksheets("List").Range("B3:B80")

    For Each rngStory In objWord.ActiveDocument.StoryRanges

        For Each x In rngXL
          strFind = x.Value
            strReplace = x.Offset(0, 1).Value

      With rngStory.Find

         .Text = strFind
         .Replacement.Text = strReplace
         .Wrap = wdFindContinue
         .Execute Replace:=wdReplaceAll

      End With

  Next
  Next


AppActivate Application.Caption
MsgBox ("US replaced with QE.  Please review changes.")

'IF NO FILE SELECTED
Ending:
End Sub

在Word中查找并替换Excel中引用的数组

2 个答案: