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