I have a VBA code that copies data from MS Word documents in a folder and pastes them into an MS Excel file. The folder contains about over 2000 MS word files. The code opens each word file in the folder and looks for two key words, lets call them "FindWord1" and "FindWord2", then copies all the data (including text) that is located between these two keywords from this word file and pastes it into a Excel worksheet. Then moves on to the next Word file in the folder.
Some of these 2000 word documents are missing the two keywords. If the code does not find the key words (either "Findword1" or "Findword2") it returns an error. So only the word documents opened before this error are copied and pasted. Is there a way to log the files names of the word documents that are missing the keywords, skip them and move on to the next file in the folder.
The code runs fine as is, but I have to manually go and remove the file from the folder for it to go to the next file which is taking a lot of time. I would appreciate any help here.
Thanks,
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
Option Explicit at the top of your module to help you enforce this.Dim FindWord1, FindWord2 As String will declare FindWord1 as Variant, you have to declare the variable type for each variable one by one i.e. Dim FindWord1 As String, FindWord2 As String.mysetyle for? It's not being used but I have left it there anyway, please delete if there is no use for it.Try below code, if the Word document does not contain both keywords then it will prompt a MsgBox and Debug.Print to the immediate window, modify to your needs:
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