Copy words from word to excel

[TA9523]

Hi,
I have 300 docx files(file name ZXXX1 and etc.), which contains a lot information. I need to find in each document words which start with "1d-", "2d-", "1e-","1 d-", "2 d-",(letters can also be uppercase "1D-" etc.) and copy this words to excel with doc file name.
At the end, I should get the following Excel file with two columns:

|Doc file name| TAG|
|-------------|-------|
|zxxxx1|1d-xxx1|
|zxxxx1|2e-xxx1|
|zxxxx2|2D-xxxxxx1|
|zxxxx3|no matches|

-("no matches" if the file does not contain words starting with
these characters)
Thanks in advance to everyone who can somehow help me.

[gmayor]

The following should work. Create a workbook with Sheet1 having two columns and a header row. Change the path and workbook name as appropriate.

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

[macropod]

Cross-posted at: vba - Copy words from word to excel - Stack Overflow
For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters

[TA9523]

Originally Posted by macropod

Cross-posted at: vba - Copy words from word to excel - Stack Overflow
For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters

Sorry for cross-reporting. In "stackoverflow" my question is showing closed, so i thought no one could see it.

[TA9523]

Gramor, thanks for help, but I have following error:
I had error in line

Set oRng = oDoc.Range With oRng.Find

- I changed oRng.Find to oRng = oDoc.Find and it start works. But next error happened when i chose folder in dialog window.
"Run-time error "429" ActivateX component can't create object" and line

Set oDoc = Documents.Open(strPath & strFile)

- highlited. How can I fix it?
Thanks in advance

[gmayor]

Set oRng = oDoc.Range With oRng.Find

should be

Set oRng = oDoc.Range 
With oRng.Find

as shown in the listing.

[TA9523]

Originally Posted by gmayor

Set oRng = oDoc.Range With oRng.Find

should be

Set oRng = oDoc.Range 
With oRng.Find

as shown in the listing.

In this case following error occur:
"compile error" - Argument not optional

[gmayor]

Put the code in a new module.
Ensure that it appears as written, with no more missing line breaks as previously noted.
It should copy from the forum without error.
Click Debug > Compile Normal.
Which line reports the error?

[TA9523]

I did everything how you wrote, the same error" Argument not optional" occurred on line

With oRng.Find

. Just for information after that google it and find solution to change line

Dim oRng As Range

to this line

Dim oRng As Word.Range

And everything work correctly, but it shows for all documents "no matches", although I checked in these documents there are suitable words. Just for note except adding "Word.Range" to line "Dim ORng" I did not do any changes in code and copy everything correctly.(Sorry for bad English and thanks in advance)

[TA9523]

UPDATED.
I can fix this problem using this code

Do While .Execute(findText:=CStr(vID(i)) & "<*>", MatchWildcards:=True)

And this code works excellent, except one thing. I have cases where tag "1D-EXX94503-A3-B25"
In this case code return only "1D-EXX94503" till the first "-" characters. How can I fix it? I think I need to return value until first space but I don't know how to realize this or maybe somebody can suggest another way

[gmayor]

The code I posted was intended to be run from Word. The error message suggest that you are running it from Excel.

[TA9523]

I tried to running it from Word, in this case error "Argument not optional" didn't occur, but whatever excel shows "no matches" for all documents. I think problem with following part of code:

Do While .Execute(findText:=CStr(vID(i)) & "[0-9]{1,}", MatchWildcards:=True)

How I said before, when I changed this part of code to this:

Do While .Execute(findText:=CStr(vID(i)) & "<*>", MatchWildcards:=True)

everything works excellent, except the cases where TAGs have two or more "-" . In this case information is copied up to the second "-". Could you suggest how can I fix it?

[gmayor]

The code I posted assumed that the 'x' indicated a number. Try instead

Do While .Execute(findText:=CStr(vID(i)) & "[0-9A-Z\-]{1,}>", MatchWildcards:=True)

See Replace using wildcards

[TA9523]

Originally Posted by gmayor

The code I posted assumed that the 'x' indicated a number. Try instead

Do While .Execute(findText:=CStr(vID(i)) & "[0-9A-Z\-]{1,}>", MatchWildcards:=True)

See Replace using wildcards

Thanks a lot. It works excellent!