Solved: How to write VBA code to copy data from Word to Excel?

[RonMcK]

Hi All,

Here where I work, we have a group of colleagues who by default like to work in MS Word. On the other hand, our systems frequently want to read MS Excel documents to import data. So, when I saw rhuman's query I realized that it is a task I want to master, as well.

How do I build one VBA program that opens both a MS Word Doc and an MS Excel xls file, with code to search the Word doc for a 'key word' (or sequence of characters), then, grab a block of text (such as a 9-digit code following the key word), copy it to the clipboard, toggle to excel, find the next row in the worksheet, paste the value, and repeat the process as needed until no more instances of the key word are found.

Here is the code I captured with Word's macro recorder; unfortunately, it did not record the window change to Excel, selection of the cell, the paste or the window change back to Word.
[vba]Sub Macro2()
'
' Macro2 Macro
' Macro recorded 7/29/08 by Ron McKenzie
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = "ID:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.EscapeKey
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=9, _
Extend:=wdExtend
Selection.Copy
'// At this point, I changed windows and pasted the ID$# (those
' 9 characters) in to the next empty row in an Excel worksheet.
'// How do I tell VBA to tell Excel to find that next row and paste
' the value?
'// Is it better to code this in Excel VBA (instead of Word VBA
' driving Excel VBA) ?
'// Further, it seems to me rather than repeating code, that I want
' to loop back to the
' top and repeat the process and let the error on selection.find.execute
' failing to find an instance of 'ID:' signal the end of processing.

Selection.Find.ClearFormatting
With Selection.Find
.Text = "ID:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Selection.Copy
'// I had 4 ID:s in my word file so this block was repeated two more times;
' omitted to save space

End Sub
[/vba]
All advice, guidance, point outs of resources (PDF docs, KB article here, stuff on other websites) and other helps will be gratefully received.

Many Thanks!

[pigeonmilk]

Try googling CreateObject("Excel.application") and look for examples

[mdmackillop]

Hi Ron,
Rather than to and fro, I would open Word, carry out the search, putting the results into an array. Close Word and write the results to the spreadsheet.

[RonMcK]

Malcolm (and Lucas, if you're lurking), et al,

Well, I found a very helpful article in the KB Extract sentences containing a specific word to excel file. After I get my cut on this working, I'll modify it so Word builds an array and Excel transfers the array into a worksheet.

The presenting problem is that VBE tells me there is an END WITH that has no WITH. But I do have the pair. Is the challenge that Lucas's code uses a DO - LOOP that has no WHILE on either end and this is confusing the compiler?

Another question, does this code automatically EXIT from the DO LOOP when SELECTION.FIND.EXECUTE fails to find any more instances of .TEXT?

Here's my modification of Lucas's code:[vba] Sub FindKeywordCopyAcctNum()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
Dim FilePath As String
Dim Keyword As String
Dim IsWindowsOS As String
intRowCount = 1
Set aRange = ActiveDocument.Range
Keyword = InputBox("Enter Keyword, Phrase or String to search for", "Search String", "ID:")
With Selection.Find
Do
.Text = Keyword 'was "ID:" ' the word I am looking for
.Execute
If .Found Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=9, Extend:=wdExtend
Selection.Copy
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application") 'Change the file path to match the location of your test.xls
If IsWindowsOS Then
FilePath = "C:\temp\test.xls" ' Windows OS
Else
FilePath = "MacintoshHD:Users:ronaldestop:test-blah.xls" 'Mac OS
End If
Set objSheet = appExcel.workbooks.Open(FilePath).Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found ' Yikes, my bad (Thanks, xld)
End With
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then 'Word vs. Excel difference - RM
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
[/vba]
Thanks in advance for your help.

[Bob Phillips]

Hasn't the While part of your Do ... Loop detached itself onto a new line?

[mdmackillop]

With some assist from here

[vba]
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim arr()
ReDim arr(1000)

'Set parameters
Tgt = "C:\AAA\Test.xls"
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)

'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
Wend
End With
End With
ReDim Preserve arr(i)

'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With

'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub

[/vba]

[RonMcK]

Malcolm,

Thank you * 10^10. This critter is magnificent and works beautifully!

[RonMcK]

Malcolm,

Here's a fragment of your code enhanced to automatically expand the array as the program approaches the upper limit. This should allow processing a document without needing to know how many instances of the search string exist in the document.

I added ArrSize and ArrIncrement as variables. I also plugged in my public function for adjusting the file path to the OS I'm running on.
[vba]Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
Dim FilePathFileName As String

txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)

With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)
[/vba]
Thanks, again!!

[mdmackillop]

Hi Ron,
This tweak avoids the loop in writing to Excel
[VBA]
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With

[/VBA]

[Bob Phillips]

With some assist from here

New kid on the block?

[RonMcK]

Hi Ron,
This tweak avoids the loop in writing to Excel
[vba]
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With[/vba]

Malcolm,

Very cool! Many thanks!

[mdmackillop]

Hi Ron,
I like the array resizing and I wanted to avoid the selection of text in the Word document. (I'm trying to improve my Word coding!)
Here's a "final" version, unless you can think of any further refinements

[VBA]
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String
Dim Tgt
Dim Lgth As Long
Dim Strt As Long
Dim i As Long
Dim oRng As Range
Dim ArrSize As Long
Dim arr()

'Set default return size
ArrSize = 50
ReDim arr(ArrSize)
'Browse for target file
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If .Show = -1 Then
Tgt = .SelectedItems(1)
End If
End With

'Set parameters
txt = InputBox("String to find")
Strt = Len(txt)
Lgth = Strt + InputBox("Length of string to return")
'Search Word Document
Set oRng = ActiveDocument.Range
oRng.Collapse wdCollapseStart
'Return data to array
With oRng
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
'Increase array if required
If i = UBound(arr) Then ReDim Preserve arr(i + ArrSize)
'Add text to array
oRng.SetRange Start:=oRng.Start + Strt, End:=oRng.Start + Lgth
arr(i) = oRng.Text
'Debug test ***************************
oRng.HighlightColorIndex = wdYellow
'**************************************
oRng.Start = oRng.End
.Execute
Wend
End With
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub

[/VBA]

[RonMcK]

Malcolm,

I'm behind/below you on the learning curve. I'm busy reading and digesting your code since I know very little about wordbasic and/or vba for Word.

I wonder what the optimum balance is between time and resources spent Re-DIMing the array and the 'cost' of memory allocated but not used? I suppose that depends in part on how many items I expect to find. Would it make sense to add an inputbox asking the user for a very rough approximation of the number of items expected in the document? We could use that number, rounded to nearest 50 or 100, for our ArrSize.

Thanks!!

[mdmackillop]

Depends whether you see this as something to be modified by as competent person or not. To idiot-proof it, the Find could be done twice, the first time just to return the value of i, to which the array size would be set. In a large document, that could still be quicker than successive redimming. I'll give it a test tomorrow.

[Bob Phillips]

Redim is expensive. My view on the general way is to take an approximate guess and dim to that size. When adding to the array, check where you are, when you get to the end, add another block of that size, and carry on. At the end redim to whatever point you have got to.