跳过 VBA 复制粘贴中的文件
Skip file in VBA copy paste
我有一个 VBA 代码，可以从文件夹中的 MS Word 文档复制数据并将它们粘贴到 MS Excel 文件中。该文件夹包含大约 2000 多个 MS word 文件。该代码打开文件夹中的每个word文件并查找两个关键字，我们称它们为“FindWord1”和“FindWord2”，然后从这个word文件中复制位于这两个关键字之间的所有数据（包括文本）并粘贴它到 Excel 工作表中。然后转到文件夹中的下一个 Word 文件。
这 2000 字文档中有一些缺少这两个关键字。如果代码没有找到关键字（“Findword1”或“Findword2”）它 returns 一个错误。所以只复制粘贴这个错误之前打开的word文档。有没有办法记录缺少关键字的word文档的文件名，跳过它们并转到文件夹中的下一个文件。
代码按原样运行良好，但我必须手动从文件夹中删除文件才能转到下一个文件，这会花费很多时间。如果有任何帮助，我将不胜感激。
谢谢，
N
'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
你在某处定义了 lngStart 和 lngEnd 吗？可能Dim他们，在打开下一个word文档后立即给他们都赋0，然后检查他们是否不等于
0 复制到 excel 部分之前。对 Word 没有任何丰富的经验 VBA，如果不适用，请见谅。
- 请记住声明所有变量，在您的模块顶部添加
Option Explicit 以帮助您执行此操作。
- 您可能已经知道这一点，但是
Dim FindWord1, FindWord2 As String 会将 FindWord1 声明为 Variant，您必须为每个变量一一声明变量类型，即 Dim FindWord1 As String, FindWord2 As String.
mysetyle 有什么用？没用过，反正我留着了，没用的请删
试试下面的代码，如果Word文档不包含这两个关键字那么它会提示一个MsgBox和Debug.Print到立即的window，修改为你的需要：
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
我有一个 VBA 代码，可以从文件夹中的 MS Word 文档复制数据并将它们粘贴到 MS Excel 文件中。该文件夹包含大约 2000 多个 MS word 文件。该代码打开文件夹中的每个word文件并查找两个关键字，我们称它们为“FindWord1”和“FindWord2”，然后从这个word文件中复制位于这两个关键字之间的所有数据（包括文本）并粘贴它到 Excel 工作表中。然后转到文件夹中的下一个 Word 文件。
这 2000 字文档中有一些缺少这两个关键字。如果代码没有找到关键字（“Findword1”或“Findword2”）它 returns 一个错误。所以只复制粘贴这个错误之前打开的word文档。有没有办法记录缺少关键字的word文档的文件名，跳过它们并转到文件夹中的下一个文件。
代码按原样运行良好，但我必须手动从文件夹中删除文件才能转到下一个文件，这会花费很多时间。如果有任何帮助，我将不胜感激。
谢谢，
N
'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
你在某处定义了 lngStart 和 lngEnd 吗？可能Dim他们，在打开下一个word文档后立即给他们都赋0，然后检查他们是否不等于
0 复制到 excel 部分之前。对 Word 没有任何丰富的经验 VBA，如果不适用，请见谅。
- 请记住声明所有变量，在您的模块顶部添加
Option Explicit以帮助您执行此操作。 - 您可能已经知道这一点，但是
Dim FindWord1, FindWord2 As String会将FindWord1声明为 Variant，您必须为每个变量一一声明变量类型，即Dim FindWord1 As String, FindWord2 As String. mysetyle有什么用？没用过，反正我留着了，没用的请删
试试下面的代码，如果Word文档不包含这两个关键字那么它会提示一个MsgBox和Debug.Print到立即的window，修改为你的需要：
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