The following should work. Create a workbook with Sheet1 having two columns and a header row. Change the path and workbook name as appropriate.
Code:
Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 29 Jan 2021
Const strWB As String = "C:\Path\IDLog.xlsx" 'must exist - change as appropriate
Const strSheet As String = "Sheet1" 'Two column worksheet with header row
Sub Batch_GetID()
Dim vID As Variant
Dim strValues As String
Dim strFile As String
Dim strPath As String
Dim oDoc As Document
Dim oRng As Range
Dim i As Integer
Dim bFound As Boolean
Dim fDialog As FileDialog
vID = Array("1d-", "2d-", "1e-", "1 d-", "2 d-", "1D-", "2D-", "1E-", "1 D-", "2 D-")
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
Do Until Right(strPath, 1) = "\"
strPath = strPath & "\"
Loop
End With
strFile = Dir$(strPath & "z*.docx")
While strFile <> ""
Set oDoc = Documents.Open(strPath & strFile)
bFound = False
For i = 0 To UBound(vID)
Set oRng = oDoc.Range
With oRng.Find
Do While .Execute(findText:=CStr(vID(i)) & "[0-9]{1,}", MatchWildcards:=True)
strValues = strFile & "', '" & oRng.Text
WriteToWorksheet strWB, strSheet, strValues
bFound = True
oRng.Collapse 0
Loop
End With
Next i
If bFound = False Then
strValues = strFile & "', '" & "no matches"
WriteToWorksheet strWB, strSheet, strValues
End If
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFile = Dir$()
DoEvents
Wend
MsgBox "Process complete"
lbl_Exit:
Set fDialog = Nothing
Set oDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function