Copy Sentences to a New Table - Extract the Paragraphs

[dj44]

folks,

good day.

I was trying to copy some sentences into a table. I had a very basic example to make 1 word search term extract. Then i wanted to extract 3 search terms and this is where it started

I added a array and a loop, but unfortunately the loop got stuck and I had a very long basic code, but that wouldnt add the sentences to the second column.

The problematic code is below






Sub CopySentencesTable()

Dim oRng As Range
Dim i As Long, lngRow As Long
Dim arrWords() As String

Dim oDoc_Source As Document
Dim oDoc_Target As Document

Dim oTbl As Table


Application.ScreenUpdating = False
Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add



oDoc_Target.PageSetup.Orientation = wdOrientLandscape
Set oTbl = oDoc_Target.Tables.Add(oDoc_Target.Range, 1, 3)

With oTbl.Rows(1)
.Cells(1).Range.Text = "DMX1"
.Cells(2).Range.Text = "DMX2"
.Cells(3).Range.Text = "DCX1"



End With
With oTbl.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideColor = wdColorGray40
.OutsideColor = wdColorGray40
End With



arrWords = Split("DMX1,DMX2,DCX1", ",")

Set oRng = ActiveDocument.Range
For i = 0 To UBound(arrWords)
Set oRng = ActiveDocument.Range
With oRng.Find

Do While .Execute(FindText:=arrWords(i))

If .Found Then
oRng.Expand Unit:=wdSentence ' Copy Paragraph


With oTbl
.Rows.Add
.Rows.Last.Range.Cells(1).Range.Text = arrWords(i)
.Rows.Last.Range.Cells(2).Range.Text = arrWords(i)
.Rows.Last.Range.Cells(3).Range.Text = arrWords(i)
End With


End If
oRng.Collapse 0
Loop


End With
Next


End Sub



Now as a far as i know it looks ok in the set up excluding the table loop area

I found many other copy sentences to a new document code but I could not make them work, as they only extract 1 word.

Please do advise, an array may not be the best way, but i only added that later becuase i couldnt make the simple ones work

Thank you for your time

[gmaxey]

I really have no idea what you are trying to do, but you are not finding anything because you are searching in ActiveDocument (which is the document with th table) vice oSource_Document


Sub CopySentencesTable()
Dim oRng As Range
Dim i As Long, lngRow As Long
Dim arrWords() As String
Dim oDoc_Source As Document, oDoc_Target As Document
Dim oTbl As Table
Application.ScreenUpdating = False
Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add
With oDoc_Target
.PageSetup.Orientation = wdOrientLandscape
Set oTbl = .Tables.Add(oDoc_Target.Range, 1, 3)
End With
With oTbl
With .Rows(1)
.Cells(1).Range.Text = "DMX1"
.Cells(2).Range.Text = "DMX2"
.Cells(3).Range.Text = "DCX1"
End With
With .Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideColor = wdColorGray40
.OutsideColor = wdColorGray40
End With
End With
oDoc_Source.Activate
arrWords = Split("DMX1,DMX2,DCX1", ",")

For i = 0 To UBound(arrWords)
Set oRng = oDoc_Source.Range
With oRng.Find
Do While .Execute(FindText:=arrWords(i))
oRng.Expand Unit:=wdSentence ' Copy Paragraph
With oTbl
.Rows.Add
.Rows.Last.Range.Cells(1).Range.Text = arrWords(i)
.Rows.Last.Range.Cells(2).Range.Text = arrWords(i)
.Rows.Last.Range.Cells(3).Range.Text = arrWords(i)
End With
oRng.Collapse 0
Loop
End With
Next
Application.ScreenUpdating = Ture

End Sub

[dj44]

Hello Greg,

good day.

I am trying to extract each search term paragraph into its own column.

to make it easier for me to see some paragraphs from the main document.

So all the

DMX1 paragraphs > Column 1
DMX2 paragraphs > Column 2
DCX1 paragraphs > Column 3



With oTbl
.Rows.Add
.Rows.Last.Range.Cells(1).Range.Text = arrWords(i)
.Rows.Last.Range.Cells(2).Range.Text = arrWords(i)
.Rows.Last.Range.Cells(3).Range.Text = arrWords(i)
End With



I couldnt work out how to add the next array item set of paragraphs to next Column was the problem i couldnt solve yet

[gmaxey]

Sentence or Paragraph? You say one, then you use the other in the code. Your Title is both!

[gmaxey]

Try this:


Sub CopySentencesTable()
Dim oRng As Range
Dim i As Long, lngRow As Long
Dim arrWords() As String
Dim oDoc_Source As Document, oDoc_Target As Document
Dim oTbl As Table
Application.ScreenUpdating = False
Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add
With oDoc_Target
.PageSetup.Orientation = wdOrientLandscape
Set oTbl = .Tables.Add(oDoc_Target.Range, 1, 3)
End With
With oTbl
With .Rows(1)
.Cells(1).Range.Text = "DMX1"
.Cells(2).Range.Text = "DMX2"
.Cells(3).Range.Text = "DCX1"
End With
With .Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideColor = wdColorGray40
.OutsideColor = wdColorGray40
End With
End With
oDoc_Source.Activate
arrWords = Split("DMX1,DMX2,DCX1", ",")
For i = 0 To UBound(arrWords)
Set oRng = oDoc_Source.Range
With oRng.Find
Do While .Execute(FindText:=arrWords(i))
oRng.Expand Unit:=wdSentence ' Copy Paragraph
With oTbl
.Rows.Add
.Rows.Last.Range.Cells(i + 1).Range.Text = oRng.Text
End With
oRng.Collapse 0
Loop
End With
Next
Application.ScreenUpdating = True
oDoc_Target.Activate
End Sub

[dj44]

Hello Greg,

pardon me, yes a sentence and a paragraph are 2 different things in vba.

Becaues thats why we have wdSentence and wdParagraph

Well i use it so loosely in every day language - i think they are the same thing in my mind.

Thank you for fixing up this mess, well I was extracting one by one as is my usual system, but then i had 3 documents open with 3 sets in 3 different documents, yes that was a bit of a problem instead of making my life easier i made it triple trouble.


I will post back later i need to work out how to move the 2nd column text it extratced to the top at the moment it leaves blank cells at the top

I hope its not a difficult formula, but i will try

i will do some experimentation on this line

.Rows.Last.Range.Cells(i + 1).Range.Text = oRng.Text

the thought of a loop and array together gives me heart palpitations
i dont know how i get myself tangled up in these 2 suspects when i try to avoid them :grinhalo:

thank you for your help as always

[dj44]

Hello Greg and folks,


Well I wasn't able to work out the formula for the array to move the next set of search terms to the top
i spent the whole day on this learning about arrays yet again - which goes in through one ear and out the other.

and my computer has been very difficult today :dau:

So I came up with the Poor Man script which took me forever

but it seems to extract right to the top , not the most attractive of scripts like me :grinhalo: . . . ..but i tried





Sub ExtractSentencesTable()

' Version 100th or something


Dim oDoc_Source As Document
Dim oDoc_Target As Document

Dim oSearch1 As String
Dim oSearch2 As String
Dim oSearch3 As String

Dim oTable As Table
Dim oRange As Range
Dim n As Long



Application.ScreenUpdating = False

Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add


'------- TABLE DESIGN
With oDoc_Target
.Range = "" 'Make sure document is empty
.PageSetup.TopMargin = CentimetersToPoints(3)

.PageSetup.Orientation = wdOrientLandscape

Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False

.Cell(1, 1).Range.Text = " Search 1"
.Cell(1, 2).Range.Text = " Search 2"
.Cell(1, 3).Range.Text = " Search 3"

.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
'----------------------------------------------




'-----SEARCH WORD 1
With oDoc_Source

n = 1
Set oRange = .Range
With oRange.Find
Do While .Execute(FindText:="MXC1", MatchWholeWord:=True)
oRange.Expand Unit:=wdParagraph
oSearch1 = oRange
oRange.Collapse 0
oTable.Rows.Add

With oTable
.Cell(n + 1, 1).Range.Text = oSearch1
End With
n = n + 1


Loop
End With
'-----------------------

'-----SEARCH WORD 2
With oDoc_Source

n = 1
Set oRange = .Range
With oRange.Find
Do While .Execute(FindText:="MXC2", MatchWholeWord:=True)
oRange.Expand Unit:=wdParagraph
oSearch2 = oRange
oRange.Collapse 0
oTable.Rows.Add

With oTable
.Cell(n + 1, 2).Range.Text = oSearch2
End With
n = n + 1


Loop
End With
'-----------------------



'-----SEARCH WORD 3
With oDoc_Source

n = 1
Set oRange = .Range
With oRange.Find
Do While .Execute(FindText:="MC15", MatchWholeWord:=True)
oRange.Expand Unit:=wdParagraph
oSearch3 = oRange
oRange.Collapse 0
oTable.Rows.Add

With oTable
.Cell(n + 1, 3).Range.Text = oSearch3
End With
n = n + 1


Loop
End With
'-----------------------


'Add more search if needed




End With
End With
End With


Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub






I added some stuff to the array that i shouldnt have but some times i have to guess

i'll keep my array untill i can work out the formula

[gmaxey]

Didn't I show you once already how to use an array for your search terms? Now you are just adding rows regardless if you need them or not:


Sub ExtractSentencesTable()
Dim oDoc_Source As Document, oDoc_Target As Document
Dim oTable As Table
Dim oRange As Range
Dim lngIndex As Long, lngTerm As Long
Dim arrSearch() As String
Dim bAddRow As Boolean
Application.ScreenUpdating = False
Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add
With oDoc_Target
.Range = vbNullString
.PageSetup.TopMargin = CentimetersToPoints(3)
.PageSetup.Orientation = wdOrientLandscape
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = " Search 1"
.Cell(1, 2).Range.Text = " Search 2"
.Cell(1, 3).Range.Text = " Search 3"
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
arrSearch = Split("MXC1,MXC2,MC15", ",")
For lngTerm = 0 To UBound(arrSearch)
With oDoc_Source
Set oRange = .Range
With oRange.Find
Do While .Execute(FindText:=arrSearch(lngTerm), MatchWholeWord:=True)
oRange.Expand Unit:=wdParagraph
bAddRow = True
With oTable
For lngIndex = 1 To oTable.Rows.Count
If Len(.Cell(lngIndex, lngTerm + 1).Range.Text) = 2 Then
.Cell(lngIndex, lngTerm + 1).Range.Text = oRange.Text
bAddRow = False
Exit For
End If
Next lngIndex
If bAddRow Then
.Rows.Add
.Cell(.Rows.Count, lngTerm + 1).Range.Text = oRange.Text
End If
End With
oRange.Collapse 0
Loop
End With
End With
Next lngTerm
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub

[dj44]

Hello Greg,

sincerley you are the nicest person always helping others with their coding disasters, especially me
many a irritating mistake i make all the time :)


Well I had a couple of hours spare today so I was determined to learn about these arrays for the millionth time.

To show that I was making progress but even then I just about didn't make the Script happen,

because one of the search terms went into a never ending loop and I had to wait 3 minutes at a time because the screen froze to escape :doh:

Although i joke about coding alot - it is a very serious craft and im just not equipeed with my rough skills to finess up - though i really try.


Thanks to you and graham, and paul,and m and some other folks,
VBA has helped me do some great things that I used to sit there and do manually hours and hours

as our good man Herodotus said "Force has no place where there is need of skill",

he should have seen my computer today i was trying to force the code in the wrong places :grinhalo:


So im glad you are good enough to be here, And from the good man of budhism who said
"Share your knowledge.It’s a wayto achieve immortality.Dalai Lama (1357 – 1419)

thank you for the good help i recieve all the time