Solved: Copy from Word to Excel with samples

[AaronT]

Hi All,

I've created a macro to search through a word doc and find any instance of bracketed text ({*}). Now I would like to copy this information to excel much like creating a log. I created a version that builds an array then simply pasts the copied array to excel. This worked well until I had a doc with thousands of these fields (I got an "overflow" error message). I've attached a sample word doc and excel spreadsheet. I was working on the "copy to excel" sub and I thought I would look to the forums for suggestions re: better or more efficient way to get this done. Ideally I would like to test if the workbook is already open and paste from there. Any assistance would be much appreciated. Thanks in advance!

Aaron

attachments:
3948 Excel
3949 Word Doc

My code so far :-):

Sub FindAndCopyFieldsIntoSpreadsheet()
Dim strDefFields, strFoundText As String
Dim objClipboard As DataLabel
Dim intFieldCounter As Integer
intFieldCounter = 0

On Error GoTo Emessage:
'Set cursor on first page
Selection.GoTo What:=wdGoToSection, Which:=wdGoToNext, Name:="1"

'Do until end of document
Do Until ActiveDocument.Bookmarks("\Sel") = ActiveDocument.Bookmarks("\EndOfDoc")
Selection.Find.ClearFormatting

'Text to find
With Selection.Find

'Any text with {} around it. Remember to use \ backslash with special characters like the {}
.Text = "\{*\}"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
'Wildcards is set to true to allow for {*}
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

'Find
Selection.Find.Execute

'If found do this.
If Selection.Find.Found = True Then
' ********************* OLD Version Code. Got overflow for building array. Pasting one-by-one now
'Tell me when the a matching string is found.
'MsgBox "This text found: " & Selection.Text
'Assign to string
'strFoundText = Selection.Text
'strDefFields = strFoundText & vbCrLf & strDefFields

' ********************* OLD Version Code. Got overflow for building array. Pasting one-by-one now

'Counter marks the number of fields and what row to paste the field into
intFieldCounter = intFieldCounter + 1
strDefFields = Selection.Text

'Copy string to clipboard
Text2Clipboard (strDefFields)
'Open DefField_ImportOnly.xls in same folder as this doc and paste your fields
Call OpenDFIO_And_Paste(intFieldCounter)

Else 'No instances then exit
MsgBox intFieldCounter & " fields were found."
intFieldCounter = 0
Exit Do

End If

'Done
Loop

Exit Sub
Emessage:
MsgBox "Error: " & Err.Description
Exit Sub

End Sub

[AaronT]

Follow-up to my last post. This is the "copy from word to excel" sub I've been working on all day. Thanks again!

Aaron

Sub OpenDFIO_And_Paste()
Dim PathToUse, FName, MyBookName As String
Dim xlApp As Excel.Application
Dim Workbook, xlTargetWB As Excel.Workbook
Dim xlTargetWS As Excel.Worksheet
Dim ExcelWasNotRunning As Boolean
PathToUse = ActiveDocument.Path & "\"
FName = "DefField_ImportOnly.xls"
MyBookName = PathToUse & FName
On Error Resume Next
'If the workbook is not open, open it
Set wBook = Workbook(ActiveDocument.Path & "\DefField_ImportOnly.xls")
If wBook Is Nothing Then 'Not open
MsgBox "Workbook is not open"
Set wBook = Nothing
On Error GoTo 0

Else 'It is open
MsgBox "Yes it is open"
Set wBook = Nothing
On Error GoTo 0
End If







End Sub

[Tinbendr]

The Excel attachment you posted was invalid.

Please use VBA tags around your code. It makes it so much easier to read.

While I applaud your efforts in the code, I decided to take a different approach to your problem.

I'm guessing that the Excel file is actually a type of log file. IMHO, this is where the code should reside. Not in your source files.

So with that in mind, drop the following into a module in your Excel file. It allows you to select the source file. It adds the data to the end of the last data so you can run multiple imports if needed.

Please post back if you have questions.

Sub CopyCurlyFieldsFromWord()
Dim WB As Workbook
Dim WS As Worksheet
Dim oWord As Word.Application
Dim WordWasNotRunning As Boolean
Dim oDoc As Word.Document
Dim wRng As Word.Range
Dim xRow As Long
Dim Fname As Variant

Set WB = ActiveWorkbook
Set WS = WB.Worksheets(1)

'Get existing instance of Word if it's open; otherwise create a new one
On Error Resume Next

Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
WordWasNotRunning = True
End If

On Error GoTo Err_Handler

'Prompt to select file
Fname = Application.GetOpenFilename("Word Files (*.doc; *.docx), *.doc; *.docx")

Set oDoc = oWord.Documents.Open(Fname, Visible:=False)
Set wRng = oDoc.Range

'Get the last row
xRow = WS.Range("A65536").End(xlUp).Row

Do
With wRng.Find
.Text = "\{*\}"
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
If wRng.Find.Found Then
'Increment the row
xRow = xRow + 1
'Add the Find to the worksheet
WS.Range("A" & xRow) = wRng
End If
Loop While wRng.Find.Found

oDoc.Close savechanges:=wdDoNotSaveChanges

If WordWasNotRunning Then
oWord.Quit
End If

'Make sure you release object references.
Set oWord = Nothing
Set oDoc = Nothing

'quit
Exit Sub

Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " _
& Err.Number
If WordWasNotRunning Then
oWord.Quit
End If

End Sub

[Paul_Hossler]

One quick thing to try to see if you're getting integer (32,000+ max) overflow is to change


Dim intFieldCounter As Integer


to


Dim intFieldCounter As Long


Paul

[AaronT]

This site is amazing! Thanks Paul for all your help. Both posts helped tremendously! I tried running the code and seem to be in a pickle. I am getting an error (object or methind not found) on this line:

VBA:
Fname = Application.GetOpenFilename("Word Files (*.doc; *.docx), *.doc; *.docx")

My apologies - I should have provided some more information. I am using Word and Excel 2003. I tried tweaking that line to use:


VBA:
Fname = Application.FileDialog(msoFileDialogFilePicker)


without success. Thank you all for the assistance!

Aaron

PS - re: integer vs. long, I was just thinking that as I read your post. :-)

[fumei]

Just a note. You may as well stop using Integer completely, as VBA converts all integer to long for its internal processes. BUT, you can still get errors re: original declaration. So you may as well use Long to start with.

[Tinbendr]

I am getting an error (object or methind not found) on this line:

VBA:
Fname = Application.GetOpenFilename("Word Files (*.doc; *.docx), *.doc; *.docx")
You are running this from Excel, yes?

I wrote this in Excel 2003.

David

[AaronT]

Oh! I see! I was actually running this from MS Word. I will try from Excel now.

[AaronT]

Holy Moly! Thank you, David! It worked beautifully. I had to step back and laugh for a minute..I spent the morning trying to get it to work in MS Excel.

Thank you, again! :clap:

[nlk634]

Is there a way to eliminate duplicates from being copied and pasted?

[nuky8181]

Hi,

Is there a way to select a few sentence and copy to excel using this method?

for example,

HEADING_1
- text1
- text2
- text3
HEADING_2: with comment (Comment is always different)

I need to copy the text and the text can be up to 6 lines. I found some post stating to find HEADING_1 then use Selection.MoveDown till HEADING_2 is reached.

The problem is I can't use selection as the file is not open. Also, I prefer it not to be opened, as yours allow.

Finally, I need to copy the text and past into excel accordingly
eg
- text1 into cell A1
- text2 into cell A2
- text3 into cell A3

Could someone give me some advise?