Question

我有使用VBA Excel宏搜索Word文件中的单词并将其粘贴到Excel表格单元格的代码，但我的代码现在重复多次相同的查找功能：

Sub test()
Dim Word As Object
Dim WordDoc As Object
Dim r, f As Boolean, fO As Long
Set Word = CreateObject("Word.Application")
Set WordDoc = Word.Documents.Open(Filename:=Application.ThisWorkbook.path & "\test.docx")
'''Name'''
Set r = WordDoc.Range
Do
With r.Find
    .ClearFormatting
    .Text = "name*author"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
                If f Then
                    If r.Start = fO Then
                Exit Do
                    End If
                Else
                    fO = r.Start
                    f = True
                End If
                WordDoc.Range(r.Start + 4, r.End - 6).Copy
                Range("C4").Select
                ActiveSheet.Paste
                Set r = WordDoc.Range(r.End, r.End)
            Else
                Exit Do
            End If
        End With
    Loop
'''Exercise'''
Set r = WordDoc.Range
Do
With r.Find
    .ClearFormatting
    .Text = "exercise*book"
    ...
                WordDoc.Range(r.Start + 8, r.End - 4).Copy
                Range("C6").Select
                ActiveSheet.Paste
                Set r = WordDoc.Range(r.End, r.End)
            Else
                Exit Do
            End If
        End With
    Loop
End Sub

如何避免代码重复？

有人可以帮我这些吗？提前谢谢！

Answer 1

您可以将重复的代码移动到这样的函数/ sub：

Set r = WordDoc.Range
Do While UnifiedSearch (r, "name*author")
    If f Then
        If r.Start = fO Then
            Exit Do
        End If
    Else
        fO = r.Start
        f = True
    End If
    WordDoc.Range(r.Start + 4, r.End - 6).Copy
    Range("C4").Select
    ActiveSheet.Paste
    Set r = WordDoc.Range(r.End, r.End)
Loop
'''Exercise'''
Set r = WordDoc.Range
Do While UnifiedSearch (r, "exercise*book")
    WordDoc.Range(r.Start + 8, r.End - 4).Copy
    Range("C6").Select
    ActiveSheet.Paste
    Set r = WordDoc.Range(r.End, r.End)
Loop
End Sub

Private Function UnifiedSearch(r as Range, s As String) As Boolean

     With r.Find
        .ClearFormatting
        .Text = s
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        UnifiedSearch = .Execute
    End With

End Function

避免代码重复

1 个答案: