Search across a large number of files and extract certain rows into a separate single file based on search string - vba

Question

I am new to working with Macro's & VBA in Microsoft Word and also "programming".
I have over 100 separate Microsoft Word files with the name structure "ABC - XXXX.docx". They range from "ABC - 1800.docx" to ABC - 2020.docx"
Within each of these files is a single large table (with a variable, but large, number of rows).
I would like to be able to search across all these files at one time (in a batch) to find and extract (but not delete) the rows that contain a specific string - for example "Date Needed". These rows should be put into a new file called "XYZ- Exceptions.docx".
I would like to be able copy the whole row (which consists of 10 columns) and retain the formatting of the data within the columns. The search string can be anywhere within the row and within any column.
If this "extract" file could then be sorted on up to three columns that would be even better.
I also have a separate need to extract all the rows from all the files with a blank in the second column.
A little guidance on what code structures, syntax and functionality to use to process this in simple terms would be very helpful.
Thank you.

Answer 1

You have two projects in your post. One project per thread, please.
For the first project:
Sub Demo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set wdDocTgt = Documents.Add
'Find all files whose names begine with "ABC - "
strFile = Dir(strFolder & "\ABC - *.doc", vbNormal)
While strFile <> ""
Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDocSrc.Range.Tables(1).Range
'Find all rows containing "Date Needed"
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Date Needed"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
End With
Do While .Find.Execute
If .Information(wdWithInTable) = True Then
'Replicate the row in the output document
wdDocTgt.Range.Characters.Last.FormattedText = .Duplicate.Rows(1).Range.FormattedText
Else
Exit Do
End If
.Collapse wdCollapseEnd
Loop
End With
wdDocSrc.Close SaveChanges:=False
strFile = Dir()
Wend
With wdDocTgt
'Sort the table
.Tables(1).Sort ExcludeHeader:=False, CaseSensitive:=False, _
FieldNumber:="Column 1", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:="Column 2", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:=wdSortOrderAscending, _
FieldNumber3:="Column 3", SortFieldType3:=wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending
'Save the output document
.SaveAs2 FileName:=StrPth & StrFld & "\XYZ - Exceptions.docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
End With
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function