查找并替换VBA宏过大

Question

我使用这个宏来搜索和替换多个单词文档中的值。

问题是，我有很多值，这些值应该被更改，它不会运行，说：

程序太大

我试图找到一个解决方案，但到目前为止都没有成功。如果有人能提供解决方案，我将不胜感激！

Sub DoReplace()
Const Find1 = "FIND TEXT"
Const Replace1 = "REPLACE TEXT"
Const Find2 = "FIND TEXT"
Const Replace2 = "REPLACE TEXT"
Const Find3 = "FIND TEXT"
Const Replace3 = "REPLACE TEXT"
Dim FilePick As FileDialog
Dim FileSelected As FileDialogSelectedItems
Dim WordFile As Variant  ' FileName placeholder in selected files loop
Dim FileJob As String    ' Filename for processing
Dim WorkDoc As Object
Dim WholeDoc As Range
Dim FooterDoc As Range
On Error GoTo DoReplace_Error
    Set FilePick = Application.FileDialog(msoFileDialogFilePicker)
    With FilePick
        .Title = "Choose Report Template"
        .Filters.Clear
        .Filters.Add "Word Documents & Templates", "*.do*"
        .Filters.Add "Word 2003 Document", "*.doc"
        .Filters.Add "Word 2003 Template", "*.dot"
        .Filters.Add "Word 2007 Document", "*.docx"
        .Filters.Add "Word 2007 Template", "*.dotx"
        .Show
    End With
    Set FileSelected = FilePick.SelectedItems
    If FileSelected.Count <> 0 Then
        For Each WordFile In FileSelected
            FileJob = WordFile
            Set WorkDoc = Application.Documents.Open(FileJob, , , , , , , , , , , False)
            Set WholeDoc = WorkDoc.Content
            Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
            Set FooterPage1 = WorkDoc.Sections(1).Footers(wdHeaderFooterFirstPage).Range
            With FooterPage1
                .Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
                .Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
                .Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
            End With
            With FooterDoc
                .Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
                .Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
                .Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
            End With
            With WholeDoc.Find
                .Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
                .Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
                .Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
            End With
            WorkDoc.Save
            WorkDoc.Close
        Next
    End If
    MsgBox "Completed"
DoReplace_Exit:
    Set WholeDoc = Nothing
    Set FilePick = Nothing
    Set WorkDoc = Nothing
    Set FooterDoc = Nothing
    Exit Sub
DoReplace_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
    Resume DoReplace_Exit
End Sub

Answer 1

这是如何处理这种情况的示例。

Option Explicit
Sub DoReplace()
    Dim FilesSelected As FileDialogSelectedItems
    Dim WordFile As Variant    ' FileName placeholder in selected files loop
    Dim WorkDoc As Document
    Dim WholeDoc As Range
    Dim FooterDoc As Range
    Dim FooterPage1 As Range
    Dim arrPair(0 To 2, 0 To 1) As String

    On Error GoTo DoReplace_Error
    ' Load the Array with pairs
    arrPair(0, 0) = "FIND TEXT"
    arrPair(0, 1) = "REPLACE TEXT"
    arrPair(1, 0) = "FIND TEXT"
    arrPair(1, 1) = "REPLACE TEXT"
    arrPair(2, 0) = "FIND TEXT"
    arrPair(2, 1) = "REPLACE TEXT"
    ' Get all the selected files
    Set FilesSelected = GetSelectedFiles
    If FilesSelected.Count <> 0 Then
        For Each WordFile In FilesSelected
            Set WorkDoc = Application.Documents.Open(WordFile, , , , , , , , , , , False)
            Set WholeDoc = WorkDoc.Content
            Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
            Set FooterPage1 = WorkDoc.Sections(1).Footers(wdHeaderFooterFirstPage).Range
            ' Replace the values
            Call FindAndReplace(arrPair, WholeDoc)
            Call FindAndReplace(arrPair, FooterDoc)
            Call FindAndReplace(arrPair, FooterPage1)
            WorkDoc.Close SaveChanges:=True
        Next
    End If
    MsgBox "Completed"
DoReplace_Exit:
    Set WholeDoc = Nothing
    Set WorkDoc = Nothing
    Set FooterDoc = Nothing
    Exit Sub

DoReplace_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
    Resume DoReplace_Exit
End Sub
' Procedure to find and replace.
Sub FindAndReplace(ByVal arrValuePair As Variant, ByRef oSection As Object)
    Dim i As Long
    If UBound(arrValuePair, 2) = 1 Then
        With oSection
            For i = LBound(arrValuePair, 1) To UBound(arrValuePair, 1)
                .Find.Execute arrValuePair(i, 0), True, True, , , , True, , , arrValuePair(i, 1), wdReplaceAll
            Next i
        End With
    End If
End Sub

' Function to get the collection of selected files.
Function GetSelectedFiles() As FileDialogSelectedItems
    Dim FilePick As FileDialog
    Set FilePick = Application.FileDialog(msoFileDialogFilePicker)
    With FilePick
        .AllowMultiSelect = True
        .Title = "Choose Report Template"
        .Filters.Clear
        .Filters.Add "Word Documents & Templates", "*.do*"
        .Filters.Add "Word 2003 Document", "*.doc"
        .Filters.Add "Word 2003 Template", "*.dot"
        .Filters.Add "Word 2007 Document", "*.docx"
        .Filters.Add "Word 2007 Template", "*.dotx"
        .Show
    End With
    'Return the value
    Set GetSelectedFiles = FilePick.SelectedItems
End Function

我希望这能有所帮助。：）