Solved: Find, Copy Text from Word and paste in excel

Hello all,
We have over a 2000 pages in word that contain IDs that we need to get into excel.

The basic steps are:
1. Find "ID:" in word
2. Copy the 9 digit ID that follows.
3. Paste in Excel next available Row
4. Repeat step 1-3.

Thanks

Have you found a solution for this, yet? Are you still looking for one?

If so, how many times does "ID:" typically occur on a page? Once the account numbers are extracted to an Excel worksheet, do you want them sorted in any particular fashion?

Thanks,

RHuman,

Here is a solution. Our very own Malcolm (mdmackillop) did the research and heavy lifting; I just tweaked it a bit so it should work better for you and your 20k page document.

Direction: Open your word doc, select Tools > Macro > Visual Basic Editor (or just press alt-F11), Select Insert > Module, copy and paste this code into the module, Save the document (ctl-S).

You need to edit the file path to where you will put the Excel workbook and the file name you gave/will give it. You must save the Excel workbook of that name in that location before you run this macro.

This program was generalized to ask the user (you) for the string it needs to search for, and the length of the string it writes to Excel. In your case, you will want it to search for <u>"ID:"</u> (omit the dbl quotes when entering) and you want it to copy the <u>9-characters</u> following that string.

You can start this program either by clicking the Excel icon (upper left of toolbar) and, then, selecting Tools > Macro > Macros and picking 'WordDataToExcel'. Or while in the VBE, you can press the right-pointing arrowhead in the toolbar.

[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 TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)

'Set parameters Change to your path and filename
TgtFile = "test-blah.xls"
If IsWindowsOS Then
Tgt = "C:\Documents and Settings\ron\My Documents\My Work\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:ronald:Destop:" & TgtFile 'Mac OS
End If
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
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
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

Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
[/vba] I hope this helps you. Please post any questions you have.

Cheers!

Thanks guys.. Works like a charm:beerchug:

R,

Glad we could help! Please mark the thread as Solved (see Thread Tools).

Thanks!

I am using a slightly modified version of the code posted above by RonMcK (thanks for posting it) but in my case, I need at times, to search for strings that are fairly large (i.e. 600). It looks like the code bugs out at 255. any work around this issue?
Thanks