In the report I'm working with with, each line representing one kind of data. Therefore my guess is that it would be end-of-line delimited. Here's an example of what one looks like:
Product Line: ABC1234
Warehouse: ZZZZZZ
Cust ID: 1234
Cust ID: 12345
Cust ID: 123456
Cust ID: 1233
Review: HS
I'm trying to create
one macro that goes through the entire document, selects each line of information, and pastes that line into a new Excel cell. This works fine if there is only one instance of each type of data, but for Cust ID there could be several. So my theory is to select one at a time, paste it into Excel, and then delete it from the Word document. Then select again looking for a second instance and, if found, copy/paste it into Excel and delete from the Word document. This loop should occur until no more are Cust IDs are found. At that time it should move on to look for the Review. Here's my current code. I've just found out that in any sale there could be anywhere from 1-8 Cust IDs and from 3-5 numbers long
Sub CreateNewExcelWB()
'This module found at -
' to test this code, paste it into a Word module
' add a reference to the Excel-library
Application.ScreenUpdating = False
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Integer
Set xlApp = CreateObject("Excel.Application"

xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
With xlWB.Worksheets(1)
'******************FIND THE PRODUCT LINE
Call CallCurrentPage
With Selection.Find
.Text = "Product Line:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
' paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
'******************FIND THE WAREHOUSE
Call CallCurrentPage
With Selection.Find
.Text = "Warehouse:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
' paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
'******************FIND THE FIRST CUSTOMER ID
Call CallCurrentPage
With Selection.Find
.Text = "Cust ID:*"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found Then
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
'Paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
'Delete the value
Selection.Delete Unit:=wdCharacter, Count:=1
Else
MsgBox "There is something wrong with this sale because there is no customer listed. Review this ASAP!", vbCritical, "Error"
End If
'******************FIND THE SECOND CUSTOMER ID
Call CallCurrentPage
With Selection.Find
.Text = "Cust ID:*"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found Then
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
'Paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
'Delete the value
Selection.Delete Unit:=wdCharacter, Count:=1
Else
With xlWB.Worksheets(1)
ActiveCell.offset(, 8).Select
End With
GoTo SelectReview
End If
'******************FIND THE THIRD CUSTOMER ID
Call CallCurrentPage
With Selection.Find
.Text = "Cust ID:*"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found Then
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
'Paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
'Delete the value
Selection.Delete Unit:=wdCharacter, Count:=1
Else
With xlWB.Worksheets(1)
ActiveCell.offset(, 8).Select
End With
GoTo SelectReview
End If
'******************FIND THE FOURTH CUSTOMER ID
Call CallCurrentPage
With Selection.Find
.Text = "Cust ID:*"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found Then
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
'Paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
Else
With xlWB.Worksheets(1)
ActiveCell.offset(, 8).Select
End With
MsgBox "Done Here!"
'GoTo SelectReview
End If
SelectReview:
'******************FIND THE REVIEW TYPE
Call CallCurrentPage
With Selection.Find
.Text = "Review:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
'Select the value
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Copy the value
Selection.Copy
' paste the value into Excel
With xlWB.Worksheets(1)
ActiveSheet.Paste
ActiveCell.offset(, 1).Select
End With
End Sub
Sub CallCurrentPage()
Call CurrentPage
End Sub
Function CurrentPage() As Range
'Thread68-734214 This function selects an entire page
Dim StartPos As Long
Dim NextPageStart As Long
StartPos = Selection.Start
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
NextPageStart = Selection.Start
If Selection.Start > StartPos Then
Selection.GoTo What:=wdGoToPage, Which:=wdGoToPrevious, Count:=1
Set CurrentPage = ActiveDocument.Range(Selection.Start, NextPageStart)
Else
Set CurrentPage = ActiveDocument.Range(Selection.Start, ActiveDocument.Range.End)
End If
CurrentPage.Select
End Function
Thanks.
--
Mike
Why make it simple and efficient when it can be complex and wonderful?