在 VBA 复制粘贴中跳过文件

Question

我有一个 VBA 代码，可以从文件夹中的 MS Word 文档中复制数据并将它们粘贴到 MS Excel 文件中。该文件夹包含大约 2000 多个 MS Word 文件。代码打开文件夹中的每个单词文件并查找两个关键字，我们将它们称为“FindWord1”和“FindWord2”，然后从该单词文件中复制位于这两个关键字之间的所有数据（包括文本）并粘贴它到 Excel 工作表中。然后转到文件夹中的下一个 Word 文件。

这些 2000 字的文档中有一些缺少这两个关键字。如果代码没有找到关键字（“Findword1”或“Findword2”），则返回错误。所以只有在这个错误之前打开的word文档被复制和粘贴。有没有办法记录缺少关键字的word文档的文件名，跳过它们并转到文件夹中的下一个文件。

代码按原样运行良好，但我必须手动从文件夹中删除文件才能转到下一个文件，这需要很长时间。我将不胜感激。

谢谢，

没有

'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.

    Application.ScreenUpdating = False

'Objects
    Dim wdApp As New Word.Application, wdDoc As Word.Document
    Dim strFolder As String, strFile As String, lRow As Long
    Dim WkSht As Worksheet: Set WkSht = ActiveSheet

'Folder Location
    strFolder = "C:\Users\Folder\"
    strFile = Dir(strFolder & "*.docx", vbNormal)
    
'Loop Start

    While strFile <> ""
      Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
      lRow = WkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
      With wdDoc
      
      ' Text you want to search
        Dim FindWord1, FindWord2 As String
        Dim result As String
        FindWord1 = "Keyword1"
        FindWord2 = "Keyword2"
        
        'Style
        mystyle = ""
      
    'Defines selection for Word's find function
        wdDoc.SelectAllEditableRanges
    
    ' Move your cursor to the start of the document
        wdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory

    'Find Functionality in MS Word
     With wdDoc.ActiveWindow.Selection.Find
        .Text = FindWord1
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
             If .Execute = False Then
            MsgBox "'Text' not found.", vbExclamation
            Exit Sub
        End If
        
        ' Locate after the ending paragraph mark (beginning of the next paragraph)
        ' wdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
        
        ' Starting character position of a selection
        lngStart = wdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
        .Text = FindWord2
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        '.Style = mystyle
        If .Execute = False Then
            MsgBox "'Text2' not found.", vbExclamation
            Exit Sub
        End If
        lngEnd = wdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
    End With
    
  'Copy Selection
   wdDoc.Range(lngStart, lngEnd).Copy
        WkSht.Paste WkSht.Range("C" & lRow)
        .Close SaveChanges:=False
      End With
      
    strFile = Dir()
    Wend
    
    wdApp.Quit
    
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
    
    Application.ScreenUpdating = True
End Sub

Answer 1

1. 请记住声明所有变量，在模块顶部添加 Option Explicit 以帮助您执行此操作。
2. 您可能已经知道这一点，但 Dim FindWord1, FindWord2 As String 会将 FindWord1 声明为 Variant，您必须一一声明每个变量的变量类型，即 Dim FindWord1 As String, FindWord2 As String。
3. mysetyle 是干什么用的？没用过，反正我放在那里了，没用的请删除。

试试下面的代码，如果Word文档不包含两个关键字，那么它会在即时窗口提示MsgBox和Debug.Print，根据你的需要修改：

Private Sub Test()
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.

    Application.ScreenUpdating = False
'Objects
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    
    Dim lRow As Long
    Dim WkSht As Worksheet
    Set WkSht = ActiveSheet
    Const colPaste As Long = 3 'Column C
'Search String
    Const FindWord1 As String = "Keyword1"
    Const FindWord2 As String = "Keyword2"
    
'Folder Location
    'Const strFolder As String = "C:\Users\Folder\"
    Dim strFile As String
    strFile = Dir(strFolder & "*.docx", vbNormal)
    
'Loop Start
    While strFile <> vbNullString
        If wdApp Is Nothing Then Set wdApp = New Word.Application
        Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
              
        lRow = WkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
                                
        'Style
        mystyle = vbNullString
                  
        Dim firstRng As Word.Range
        Set firstRng = wdDoc.Range.Duplicate
      
        'Find Functionality in MS Word
        With firstRng.Find
            .Text = FindWord1
            .Replacement.Text = ""
            .Forward = True
            .Wrap = 1
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
                        
            .Execute
        End With
        
        If firstRng.Find.Found Then
            Dim secondRng As Word.Range
            Set secondRng = wdDoc.Range(firstRng.End, wdDoc.Range.End).Duplicate
            
            With secondRng.Find
                .Text = FindWord2
                .Replacement.Text = ""
                .Forward = True
                .Wrap = 1
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                
                .Execute
            End With
            
            If secondRng.Find.Found Then
                'Found both keywords, copy to worksheet
                
                Dim copyRng As Word.Range
                Set copyRng = wdDoc.Range(firstRng.Start, secondRng.End).Duplicate
                
                copyRng.Copy
                'WkSht.Cells(lRow, colPaste).Paste
                WkSht.Paste WkSht.Range("C" & lRow)
            Else
                'Error - second word not found~ abort and move on to next file
                  
                MsgBox "Second word not found" & vbNewLine & _
                strFolder & strFile
                Debug.Print "Second word not found: " & strFolder & strFile
            End If
        Else
            'Error - first word not found~ abort and move on to next file
              
            MsgBox "First word not found" & vbNewLine & _
            strFolder & strFile
            Debug.Print "First word not found: " & strFolder & strFile
        End If
                                                                                   
        Set firstRng = Nothing
        Set secondRng = Nothing
        Set copyRng = Nothing
        
        wdDoc.Close 0
        
        strFile = Dir()
    Wend
    
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set WkSht = Nothing
    
    Application.ScreenUpdating = True
End Sub

Answer 2

您是否在某处定义了 lngStart 和 lngEnd？也许Dim他们并在打开下一个单词doc后立即为两者分配0，然后检查它们是否不等于 0之前复制到excel部分。对 Word VBA 没有任何丰富的经验，如果不适用，请见谅。