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