Word to Excel Copy Multiple Words - To Many Columns

[dj44]

Hi folks,

good monday.:)

I'm trying to search for some words in my document and then extract them to excel.

It works if I do one search term at a time with 1 block of code.


But I wanted to set up multiple search words - to save me time having to go and change the code again.

and here is where I've got stuck

I'm not sure how to proceed now or if this is the best way







Option Explicit



Sub Word2ExcelCopy()


Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim oRng As Range
Dim NextRow As Integer
Dim oDoc As Document




'--- Set Up Search conditions here? May be Array

xlSheet.Cells("A" & NextRow, 1) = oRng.Text1
xlSheet.Cells("B" & NextRow, 1) = oRng.Text2
xlSheet.Cells("C" & NextRow, 1) = oRng.Text3



'- Search 1

Set xlApp = GetObject(, "Excel.Application")
Set xlSheet = xlApp.Sheets("Sheet1")
Set oRng = ActiveDocument.Range

With oRng.Find
Do While .Execute(FindText:="Test1")

oRng.Start = oRng.Start + 10
oRng.End = oRng.End - 1 ' Minus the Last Character

NextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
xlSheet.Cells(NextRow, 1) = oRng.Text
oRng.Collapse 0
Loop
End With




'-- Search 2
Set xlApp = GetObject(, "Excel.Application")
Set xlSheet = xlApp.Sheets("Sheet1")
Set oRng = ActiveDocument.Range

With oRng.Find
Do While .Execute(FindText:="Test2")

oRng.Start = oRng.Start + 14
oRng.End = oRng.End - 1

NextRow = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1
xlSheet.Cells(NextRow, 1) = oRng.Text
oRng.Collapse 0
Loop
End With


'-- Search 3
Set xlApp = GetObject(, "Excel.Application")
Set xlSheet = xlApp.Sheets("Sheet1")
Set oRng = ActiveDocument.Range

With oRng.Find
Do While .Execute(FindText:="Test3")

oRng.Start = oRng.Start + 14
oRng.End = oRng.End - 1

NextRow = xlSheet.Range("C" & xlSheet.Rows.Count).End(-4162).Row + 1
xlSheet.Cells(NextRow, 1) = oRng.Text
oRng.Collapse 0
Loop
End With



'--- maybe be more search





End Sub






please do take a look at the code, i tried an array but it was a bit too well mixed between word and excel so i went back to my basic blocks


I'll be really grateful for the help
thank you very much

[gmaxey]

In simple tests here manipulating the found range like you have resturns a null string.


Sub Word2ExcelCopy()
Dim xlApp As Object, xlBook As Object, xlSheet As Object
Dim oRng As Range
Dim lngIndex As Long, lngRow As Long
Dim oDoc As Document
Dim arrWords() As String
arrWords = Split("Test1,Test2,Test3", ",")
Set xlApp = GetObject(, "Excel.Application")
Set xlSheet = xlApp.Sheets("Sheet1")
Set oRng = ActiveDocument.Range
For lngIndex = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:=arrWords(lngIndex))
'oRng.Start = oRng.Start + 10
'oRng.End = oRng.End - 1 ' Minus the Last Character
lngRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
xlSheet.Cells(lngRow, 1) = oRng.Text
oRng.Collapse 0
Loop
End With
Next
End Sub

[dj44]

Hello Greg,

how are you hope you are doing well,

nice to see you.

Well that's cut down a couple of pages of code for me,

Well I did try to use the array but it became really complicated with different objects back and forth and I wasn't sure which one was pulling which one if that makes any sense,

So that's very nicely sorted.



But just out of curiosity

Is there a way for being able to put Text2 into column B, and Test3 into column C

let me do some testing.

Apart from that well this is something, i am quite surprised it was able to be cut down so elegantly.

My script went into two pages and I knew I was in trouble so i thought i better check here , it didnt seem right.

Let me fiddle to see if about moving it into the next column,

but i have a feeling this may be a mutlidimensional array and you know me im socks when it comes to arrays :grinhalo: