Copy 3 Paragraphs From Each Document into a 3 column table

[dj44]

Good day to all the good folks,

how is everyone doing.:grinhalo:

i am ticking along nicely until now.

Well its a long story.


I am trying to copy 3 paragraphs from a folder full of documents into 1 master table.

In each document

Paragraph 1 - ends with " - double quotation mark

Paragraph 2 - ends with the ) - Closing bracket

Paragraph Range 3 - Starts with a ' - single quotation mark and ends with a - (hyphen)




Column 1 | Column 2 | Column 3
Paragraph 1 | Paragraph 2 | Paragraph Range 3

Then loop through the next document.


Now i did try my best and google hasn't been a good friend as usual.

I found this
http://www.vbaexpress.com/forum/showthread.php?1322-Macro-to-find-string-and-copy-sentence-containing-string

I also found this from our good man Graham

http://www.vbaexpress.com/forum/showthread.php?54756-VBA-Word-Copy-Strings-into-a-Table

my 10th attempt ++




Sub Copy3ParagraphsintoTable()

' Copy 3 Paragraphs into a 3 column Table

Dim oSource As Document
Dim oTarget As Document
Dim oTable As Table
Dim oRow As Row
Dim oRng As Range
Dim sText As String
Dim oCell As Range
Dim i As Long
'Assign a variable name to the document
Set oSource = ActiveDocument
'Save the document (before changes are made to it)
oSource.Save


'Open a new document - the MASTER TABLE DOCUMENT

Set oTarget = Documents.Add
oTarget.PageSetup.Orientation = wdOrientLandscape


' Browse for the folder that has all the documents that contains the paragraphs
Dim myFolder As String, myFile As String

myFolder = GetFolder



' MAKE A NICE FORMATTED TABLE
'Create a table in that document and name the header row cells



Set oTable = oTarget.Tables.Add(oTarget.Range, 1, 2,3)
oTable.Rows(1).Cells(1).Range.Text = "Paragraph 1"
oTable.Rows(1).Cells(2).Range.Text = "Paragraph 2"
oTable.Rows(1).Cells(3).Range.Text = "Paragraph Range3"

oTable.Borders.InsideLineStyle = wdLineStyleSingle
oTable.Borders.OutsideLineStyle = wdLineStyleSingle

oTable.Borders.InsideColor = wdColorGray40
oTable.Borders.OutsideColor = wdColorGray40




'Set a range to the original document
Set oRng = oSource.Range
'Remove duplicated paragraph breaks
With oRng.Find


Do While .Execute(FindText:=" "", MatchWildcards:=True) ' FIND THE double quotation mark Paragraph 1
oRng.Text = vbCr
Loop
End With
'Reset a range to the original document
Set oRng = oSource.Range
'Locate the ID text
With oRng.Find

'paragraph 2 is missing?

'For paragraph range 3
Do While .Execute(FindText:="[']", MatchWildcards:=True)
On Error GoTo lbl_Exit


Do Until oRng.Next.Words(1) = " - " Or _ 'hyphen
oRng.End = oSource.Range.End
oRng.MoveEnd wdWord
Loop
'Include the "End" marker in the range
oRng.End = oRng.End + 3


'Add a row to the table
oTable.Rows.Add
'Set a variable name to the last row of the table
Set oRow = oTable.Rows.Last
'Fill the first cell in the row with the ID text
oRow.Cells(1).Range.Text = Split(oRng.Text, vbCr)(0)
'Clear the sText string variable
sText = ""
'Add the remaining text to the string
For i = 2 To oRng.Paragraphs.Count
sText = sText & oRng.Paragraphs(i).Range.Text
Next i
'Remove any paragraph breaks from the string
sText = Replace(sText, Chr(13), " ")
'Remove any double spaces from the string
sText = Replace(sText, " ", " ")
'Add the string to the second cell of the last row
oRow.Cells(2).Range.Text = sText
'Collapse the range to its end
oRng.Collapse 0
'And go round again
Loop
End With


'Close the original document without recording the changes
'oSource.Close 0
lbl_Exit:
Exit Sub

End Sub



Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing





Now i do believe i have been a bit too ambitious - still got my byclicle training wheels on

I'm stuck and don't know what to do any more, paragraph 2 is MIA - not sure how to weave that into the code

Ever grateful if any one can help me


thank you good folks :)

DJ

[gmaxey]

dj44,

Speaking only for myself, it is tiresome when you post code that will not even compile! Personally, I would rather just write your code than try to make sense out of a mess like this.

Nowhere in the code you posted have you made any attempt to loop through the files in your "myFolder"

You have clearly stated that each file in your folder starts with three paragraphs with specific formatting. If you already know that then why are you trying to find them with code?

"Paragraph 1 - ends with " - double quotation mark
Paragraph 2 - ends with the ) - Closing bracket
Paragraph Range 3 - Starts with a ' - single quotation mark and ends with a - (hyphen)"



Sub Copy3ParagraphsintoTbl()
Dim oSource As Document
Dim oTarget As Document
Dim oTbl As Table
Dim strFolder As String, strFile As String
Application.ScreenUpdating = False
'Create your Master Table document.
Set oTarget = Documents.Add
oTarget.PageSetup.Orientation = wdOrientLandscape
'Create a table in that document and name the header row cells
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 3)
With oTbl.Rows(1)
.Cells(1).Range.Text = "Paragraph 1"
.Cells(2).Range.Text = "Paragraph 2"
.Cells(3).Range.Text = "Paragraph 3"
End With
With oTbl.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
.InsideColor = wdColorGray40
.OutsideColor = wdColorGray40
End With

'Browse for the folder that has all the documents that contains the paragraphs
strFolder = GetFolder
strFile = Dir(strFolder & "\*.do*", vbNormal)
WordBasic.DisableAutoMacros 1 'Disables auto macros
While strFile <> ""
Set oSource = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With oTbl
.Rows.Add
.Rows.Last.Range.Cells(1).Range.Text = oSource.Paragraphs(1).Range.Text
.Rows.Last.Range.Cells(2).Range.Text = oSource.Paragraphs(2).Range.Text
.Rows.Last.Range.Cells(3).Range.Text = oSource.Paragraphs(3).Range.Text
End With
oSource.Close wdDoNotSaveChanges
strFile = Dir()
Wend
WordBasic.DisableAutoMacros 0 'Enables auto macros
Set oSource = Nothing
Application.ScreenUpdating = True
lbl_Exit:
Exit Sub
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[dj44]

Hello Greg,

my apologies x10.

Yes if i got a grade on that Im sure i would get a unianimous 0.

Well you see the problem is - I tried to take the best bits from good macros i found, which is not a good strategy, I learned later

and then when i added it, then i had to take it out when it did not work,

myFolder got stuck and nothing opened so i took it out again, and i believe i may have now misplaced the loop thing in another macro,


Yes I always fail on the loop - it always goes missing for some reason - which i know is my fault.

You know when a loop has gone missing so i can't cheat you :grinhalo:

Grahams one did work - and then i got my hands on it and well...

I thought you had to search for the quotation mark and bracket - i'm sure i got the wrong end of the stick there

and i did want to post the code so folks can see - what i did, its hard to explain code in english

Greg your code is is exceptionally talented as it always does the job perfect!!!

Also thank you i know its not your job to write code for others - it is truely tiresome as reported by my optician, i told him i am learning to code, when he asked why my specs went negative increase

So thank you very very much for helping out again :biggrin:

Good weekend to you
thanks again

DJ

[gmaxey]

Just try to learn from your mistakes and if your code won't compile then 'stet out whatever won't compile.