This code is supposed to open all files in the subfolders of my target folder and search them for specific terms, print those terms and where they were found in a text file. If it encounters an error, print that error so we know which documents to search manually.
It seems to be working, it's finding the search terms in the documents, but then it prints an error message for each file in the subfolder that it's corrupted? These files are fine to open, btw. They don't appear to be corrupted in any way. They do have tracked changes on, could that be why? I've included some sample output for one folder below the code.
FINAL CODE: thanks so much everyone for your help
Option Explicit
Sub CheckCrossRef()
Dim FSO As Scripting.FileSystemObject
Dim masterFolder As folder
Dim allSubfolders As Folders
Dim currSubfolder As folder
Dim subfolderFiles As Files
Dim currFile As File
Set FSO = Nothing
Dim leftChar As String
Dim strFolder As String
Dim strDoc As String
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim nameArchive As Word.Document
Set wordApp = New Word.Application
wordApp.Visible = True
Set nameArchive = Documents.Add(Visible:=False)
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select the folder that contains the documents."
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
Else
MsgBox "You did Not Select the folder that contains the documents."
Exit Sub
End If
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
Set masterFolder = FSO.GetFolder(strFolder)
Set allSubfolders = masterFolder.subFolders
For Each currSubfolder In allSubfolders
Set subfolderFiles = currSubfolder.Files
For Each currFile In subfolderFiles
On Error GoTo errorProcess
leftChar = Left(currFile.Name, 1)
If leftChar <> "~" Then
Set wordDoc = Word.Documents.Open(currFile.Path)
With wordDoc
Dim SearchTerm As String, i As Long, fileName As String
Dim Rng As Range, Doc As Document, RngOut As Range
Dim searchTerms As Variant
fileName = currFile.Name
searchTerms = [removed]
For i = LBound(searchTerms) To UBound(searchTerms)
SearchTerm = searchTerms(i)
With ActiveDocument.Range
With .Find
.ClearFormatting
.Text = SearchTerm
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
If .Find.Found Then
Dim valueFound As String
Do While .Find.Found
Set Rng = .Duplicate
valueFound = Rng.Text
nameArchive.Activate
ActiveDocument.Range(0, 0).Select
Selection.EndKey Unit:=wdStory
Selection.TypeText Text:=vbCrLf & valueFound & "," & fileName
wordDoc.Activate
.Collapse wdCollapseEnd
.Find.Execute
Loop
End If
End With
Next
End With
wordDoc.Close
End If
nextIteration:
Next currFile
Next
Dim newPath
newPath = FSO.BuildPath(masterFolder.Path, "SpecList.txt")
nameArchive.SaveAs2 fileName:=newPath, FileFormat:=wdFormatText
nameArchive.Close
wordApp.Quit
Set wordApp = Nothing
Set FSO = Nothing
valueFound = "null"
Set Rng = Nothing
Set masterFolder = Nothing
Set allSubfolders = Nothing
Set currSubfolder = Nothing
Set subfolderFiles = Nothing
Set currFile = Nothing
Exit Sub
errorProcess:
nameArchive.Activate
ActiveDocument.Range(0, 0).Select
Selection.EndKey Unit:=wdStory
If Err.Number <> 0 Then
If Not currFile Is Nothing Then
fileName = currFile.Name
Selection.TypeText Text:=vbCrLf & fileName & " " & Err.Number & " " & Err.Description
Else
Selection.TypeText Text:=vbCrLf & Err.Number & " " & Err.Description
End If
End If
Resume nextIteration
On Error GoTo 0
End Sub
Some greatly abbreviated output:
- 03100,03100 Concrete Formwork.docx
- 05501,03200 Concrete Reinforcement.docx
- 07920,03251 Concrete Joints.docx
- 03600,03300 Cast in Place Concrete.docx
- ~$100 Concrete Formwork.docx - 5792 The file appears to be corrupted.
- ~$200 Concrete Reinforcement.docx - 5792 The file appears to be corrupted.
- ~$251 Concrete Joints.docx - 5792 The file appears to be corrupted.
- ~$300 Cast in Place Concrete.docx - 5792 The file appears to be corrupted.
Any advice? Also if you see any other mistakes in the code feel free to correct. Thank you!
