#1
|
|||
|
|||
Copy words from word to excel
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. |
#2
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#4
|
|||
|
|||
Quote:
|
#5
|
|||
|
|||
Gramor, thanks for help, but I have following error:
I had error in line Code:
Set oRng = oDoc.Range With oRng.Find "Run-time error "429" ActivateX component can't create object" and line Code:
Set oDoc = Documents.Open(strPath & strFile) Thanks in advance |
#6
|
||||
|
||||
Code:
Set oRng = oDoc.Range With oRng.Find Code:
Set oRng = oDoc.Range With oRng.Find
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#7
|
|||
|
|||
Quote:
"compile error" - Argument not optional |
#8
|
||||
|
||||
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?
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#9
|
|||
|
|||
I did everything how you wrote, the same error" Argument not optional" occurred on line
Quote:
Quote:
Quote:
|
#10
|
|||
|
|||
UPDATED.
I can fix this problem using this code Quote:
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 |
#11
|
||||
|
||||
The code I posted was intended to be run from Word. The error message suggest that you are running it from Excel.
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#12
|
|||
|
|||
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:
Quote:
Quote:
|
#13
|
||||
|
||||
The code I posted assumed that the 'x' indicated a number. Try instead
Code:
Do While .Execute(findText:=CStr(vID(i)) & "[0-9A-Z\-]{1,}>", MatchWildcards:=True)
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#14
|
|||
|
|||
Quote:
|
Tags |
ms excel 2016, ms word, vba |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Copy & Paste Word Doc from Excel VBA | RMerckling | Excel Programming | 4 | 04-18-2018 03:57 PM |
copy a specific words to excel list | romanticbiro | Word VBA | 12 | 12-03-2014 05:12 AM |
Copy data from Word into Excel | chinchee | Word VBA | 18 | 05-23-2014 05:25 AM |
Copy and paste words on right side of page | Videolife | Word | 3 | 01-26-2013 12:54 PM |
how to copy all ms word tables into excel | rehan129 | Word | 0 | 01-28-2012 10:17 AM |