Search For Sentences - Put in a 2 Column Table

[dj44]

Hi folks,

hope everyones having a good sunday.:)

Well i thought i would catch up on some work this weekend - but now have a problem.

I was trying to copy some words into a 2 column table, but im afraid its gone wrong.

So scattered through out the document there are sentences such as these

============
CP1 : Some text
CT1: Some text

random stuff, random

CP2 : some Text
CT2 : some Text
================



I simply wanted to find these pairs of paragraphs - and put them in a 2 column table

So i would end up with

CP1 : Some text | CT1: Some text
CP2 : some Text | CT2 : some Text

and on etc


Now this is just a brief sample of the many i tried and failed to code.

http://www.msofficeforums.com/word-vba/21408-macro-search-all-words-r-place-new.html




Sub MakeTableFromWords()


Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim oTbl As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Application.ScreenUpdating = False



Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add

Set oTbl = oDoc_Target.Tables.Add(oTarget.Range, 1, 2)

oTarget.PageSetup.Orientation = wdOrientLandscape
With oTbl.Rows(1)
.Cells(1).Range.Text = "CP1"
.Cells(2).Range.Text = "CT1"

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



With oDoc_Source
Set oRange = .Range

With oRange.Find

.Text = CP1 ' Do I need a wild card search for CP1,CP2,CP3,CP4,CP5

While .Execute
oRange.MoveStart wdWord, -1
oDoc_Target.Range.InsertAfter oRange & vbCr

oRange.Collapse wdCollapseEnd
Wend
End With

With oDoc_Source
Set oRange = .Range


With oRange.Find

.Text = CT1

While .Execute
oRange.MoveStart wdWord, -1
oDoc_Target.Range.InsertAfter oRange & vbCr

oRange.Collapse wdCollapseEnd
Wend
End With


End With


End Sub



I also looked on all the forums for pointers but alot of them are too advanced and I just couldnt adapt it to this task.

I would be really grateful for any help - thank you

[gmayor]

Assuming that the numbers CT1, CT2 etc are incrementing throughout and each is followed by a matching CP# then


Sub MakeTableFromWords()

Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim oTbl As Table
Dim oRange As Range
Dim i As Long
Dim strList As String: strList = Chr(11) & Chr(13)

Set oDoc_Source = ActiveDocument
Set oDoc_Target = Documents.Add
oDoc_Target.PageSetup.Orientation = wdOrientLandscape

Set oTbl = oDoc_Target.Tables.Add(oDoc_Target.Range, 1, 2)

With oTbl.Rows(1)
.Cells(1).Range.Text = "CP1"
.Cells(2).Range.Text = "CT1"
End With

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

With oDoc_Source
For i = 1 To 100 'any number higher than the range of expected numbers
Set oRange = .Range
With oRange
If InStr(1, oRange, "CP" & i) = 0 Then
Exit For
GoTo lbl_Exit
End If
.Start = .Start + InStr(oRange, "CP" & i) - 1
.End = .Start + InStr(oRange, "CT" & i)
.MoveEndUntil strList
oTbl.Rows.Add
If InStr(1, oRange.Text, Chr(11)) > 1 Then
oTbl.Rows.Last.Cells(1).Range.Text = Trim(Split(oRange.Text, Chr(11))(0))
oTbl.Rows.Last.Cells(2).Range.Text = Trim(Split(oRange.Text, Chr(11))(1))
Else
oTbl.Rows.Last.Cells(1).Range.Text = Trim(Split(oRange.Text, Chr(13))(0))
oTbl.Rows.Last.Cells(2).Range.Text = Trim(Split(oRange.Text, Chr(13))(1))
End If
End With
Next i
End With
lbl_Exit:
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTbl = Nothing
Set oRange = Nothing
Exit Sub
End Sub

[dj44]

Hello Graham,

nice to see you and hope you are doing great! :)

I just about managed to add 1 table row and that took me a while to add the table borders and bits.

But on saturday - i went off course as there was one that looked like it would find the sentences but the table didnt appear and the sentences didnt copy so that was a dud too.

I had one from Greg, that added a paragraph to a table, but i went through all sorts to find how to do the search for the regex, but that didnt work, so i gave up on that - not for lack of trying though.

Now you have saved me so much time and effort finding those sentences and copy and pasting them,
i was finding them one by one but it was too much for my old heart to bear, as there were lots of documents, and i didnt know which one was the right one so i have to check by copy and pasting.

I have my notebook so i will add plenty of notes to the code, I can find some other stuff in my documents now too.

I really am indebted to the kindness of you folks, as i know its a hard job making the code, thank you for helping all the folks with their coding dilemmas.

And thank you for making a great monday for me and i hope you have a great monday too :grinhalo:

good day to all