create and populate a table in word

[Kilroy]

Hello all newbie to VBA here. I'm wondering if anyone knows how to create a table and populate it with paragraphs from a word document. I have up to 70+ page documents that I need to populate into a table to create checklists. I appreciate any help leading me in the right direction.

Thanks

Kilroy

[gmayor]

Creating a table is child's play, but it would help if you explained how it relates to the document(s) that you wish to populate it with.

[Kilroy]

Creating a table is child's play, but it would help if you explained how it relates to the document(s) that you wish to populate it with.

I have manuals that I have to audit to. I take the manual and/or procedures and put it into a checklist form.


For example:


4.2DOCUMENTATION REQUIREMENTS

4.2.1Control of Documents

Documentation required by the quality system is controlled in accordance with a documented procedure. Controls exist over the approval, review, update and storage of documents.

The Quality Specialist will ensure QMS documents are reviewed and approved for adequacy by all affected units prior to issue and ensure format is consistent with all QMS documents and ensure that QMS documents are reviewed for continued suitability, updated as necessary and re-approved.

BECOMES:

16656

[gmayor]

Without access to the document, the following should be close

Option Explicit

Sub DocToTable()
Dim oSource As Document
Dim oTarget As Document
Dim oTable As Table
Dim oPara As Range
Dim oRng As Range
Dim lngRow As Long
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTable = oTarget.Tables.Add(oTarget.Range, 1, 2)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Cell(1, 1).Range
oRng.End = oRng.End - 1
oRng.Text = "Section"
Set oRng = oTable.Cell(1, 2).Range
oRng.End = oRng.End - 1
oRng.Text = "Comments"
For lngRow = 1 To oSource.Paragraphs.Count
If Len(oSource.Paragraphs(lngRow).Range) > 1 Then
oTable.Rows.Add
Set oPara = oSource.Paragraphs(lngRow).Range
oPara.End = oPara.End - 1
Set oRng = oTable.Cell(oTable.Rows.Count, 1).Range
oRng.End = oRng.End - 1
oRng.FormattedText = oPara.FormattedText
DoEvents
End If
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

[QUOTE=gmayor;346284]Without access to the document, the following should be close
[CODE]Option Explicit

What you've written is just what I asked for and I really appreciate it. During the running of this code some of the formatting is getting lost. The clauses I deal with are numbered which it seems to capture but if you see the following example the second or third level of numbering is getting lost. Also is it possible to have all numbers go into another column? I'm attaching this explanation.

[gmaxey]

Your sample document is a bit inconsistent because part the main heading appears to be manually numbered while the a), b) is are list paragraphs
Something like this:

Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As Range
Dim lngRow As Long, lngIndex As Long
Dim arrParts() As String
Dim bMainClause As Boolean
bMainClause = False
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).Range.Text = "Clause #"
.Cell(1, 2).Range.Text = "Section"
.Cell(1, 3).Range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.Range.Text) > 1 Then
oTbl.Rows.Add
If Not bMainClause Then
If IsNumeric(oPar.Range.Characters(1)) Then
arrParts = Split(oPar.Range.Text, Chr(9))
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = arrParts(0)
oTbl.Cell(oTbl.Rows.Count, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
oTbl.Cell(oTbl.Rows.Count, 2).Range.Text = arrParts(1)
bMainClause = True
End If
Else
If oPar.Range.ListFormat.ListType = wdListSimpleNumbering Then
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = oPar.Range.ListFormat.ListString
oTbl.Cell(oTbl.Rows.Count, 2).Range.Text = oPar.Range.Text
End If
End If
End If
DoEvents
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

[QUOTE=gmaxey;346352]Your sample document is a bit inconsistent because part the main heading appears to be manually numbered while the a), b) is are list paragraphs

It is true that the numbering may not have been formatted properly and I'll need to watch out for that. The table is perfect but now its only copying one paragraph. I tried it on different documents and it seemed to pick the first paragraph on one and then a random paragraph on others.

I added the first two lines from the original code you wrote:

Option Explicit
Sub DocToTable()
Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As range
Dim lngRow As Long, lngIndex As Long
Dim arrParts() As String
Dim bMainClause As Boolean
bMainClause = False
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).range.Text = "Clause #"
.Cell(1, 2).range.Text = "Section"
.Cell(1, 3).range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.range.Text) > 1 Then
oTbl.Rows.Add
If Not bMainClause Then
If IsNumeric(oPar.range.Characters(1)) Then
arrParts = Split(oPar.range.Text, Chr(9))
oTbl.Cell(oTbl.Rows.Count, 1).range.Text = arrParts(0)
oTbl.Cell(oTbl.Rows.Count, 1).range.ParagraphFormat.Alignment = wdAlignParagraphRight
oTbl.Cell(oTbl.Rows.Count, 2).range.Text = arrParts(1)
bMainClause = True
End If
Else
If oPar.range.ListFormat.ListType = wdListSimpleNumbering Then
oTbl.Cell(oTbl.Rows.Count, 1).range.Text = oPar.range.ListFormat.ListString
oTbl.Cell(oTbl.Rows.Count, 2).range.Text = oPar.range.Text
End If
End If
End If
DoEvents
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

Guys thanks so much for your efforts on this. I see what's happening now. it takes the first paragraph that has a number in front of it so long as it is a typed number and not done through pressing the numbering button. I still cannot get it to copy more than one paragraph as well.

[gmaxey]

Please put code between code tags (use the # icon on the menu). I didn't write the original code. Graham Mayor did. Our initials are the same and in some (but not all) cases our style.

The code I wrote dealt specifically with the sample text that you provided. It is just cobbled together to deal with the specific inconsistency mentioned. You can try stepping trough the coded using the F8 key to see where is fails to do what you expect it to do.

[gmaxey]

Kilroy,

As I mentioned. The code I wrote dealt specifically with the example you provided. It is not going to transfer anything until it finds a paragraph longer than one character that starts with a typed number. arrParts() splits the text of that paragraph on a tab. The first part goes in column 1 the rest in column 2. Now if in practice there are more than one tab in that paragraph then the code would need to be changes. Then and only then will if process any remaining paragraphs and then and only then if they are listtype listSimpleNumbering.

[Kilroy]

Thanks Greg I really appreciate your input. I think the code that Graham wrote generally captures what I'm trying to do so I'm hoping it can be modified to incorporate keeping the source formatting and the extra column. I'm hoping to learn a lot more about using VBA so I can also add a statement that the first row repeats as a header row on each page and also is filled in with color. Again thanks for your input.

[gmaxey]

Kilroy,

It doesn't really matter who's code you modify. Until you clearly layout your requirements and stop moving the goal posts it is unlikely that anymore will hand over a perfect solution.


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As Range
Dim lngRow As Long, lngIndex As Long
Dim arrParts() As String
Dim bMainClause As Boolean
bMainClause = False
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).Range.Text = "Clause #"
.Cell(1, 2).Range.Text = "Section"
.Cell(1, 3).Range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.Range.Text) > 1 Then
oTbl.Rows.Add
If Not bMainClause Then
If IsNumeric(oPar.Range.Characters(1)) Then
Set oRng = oPar.Range
arrParts = Split(oPar.Range.Text, Chr(9))
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = arrParts(0)
oTbl.Cell(oTbl.Rows.Count, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
oRng.End = oRng.End - 1
oRng.MoveStartUntil Cset:=vbTab
oRng.Start = oRng.Start + 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
bMainClause = True
End If
Else
If oPar.Range.ListFormat.ListType = wdListSimpleNumbering Then
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = oPar.Range.ListFormat.ListString
Set oRng = oPar.Range
oRng.End = oRng.End - 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
End If
End If
End If
DoEvents
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

Greg Thanks again for your input. This macro you posted ignores paragraphs with no numbering an only copies the text of the first paragraph with a number. It does seem to still create the full table. I've sorted out the reason it wasn't initially picking the clauses that were numbered using the "styles". All I'm looking for is to copy all text to column 2 and separate the numbers and put them into column one. The layout of the numbers could be 1, 1.0, 1.1, 1.1.1, 1.1.1.1.. Hope fully I'm getting my point across I hate to keep asking for help.

Regards

Kilroy

[gmaxey]

Kilroy,

As I have already stated, the macro I posted processes your sample clause which was not formatted and every paragraph was either manually numbered or was a list paragraph.

16709

This is not a macro writing service. If you can't work it out from what you have already been handed then you might consider hiring someone to do it for you.

[Kilroy]

Greg I did resolve the formatting of the numbering like I said above that's not an issue now. The issue is that the macro you wrote is copying the first instance it finds of a numbered paragraph and ignoring all other numbered paragraphs after and also it doesn't copy any paragraph that doesn't have a number. FYI I would be happy to make a donation to whom ever can help me solve this issue.

[gmaxey]

How am I supposed to know what your document may look like if you don't post one (an example of one and the resulting document with the table)? The code I wrote processes you sample text period. Regardless of how many other paragraphs there may be numbered or not.

Personally, I don't work for donations. You may be able to hire someone using links on this site or if you want to hire me you can contact me via my website feedback.

[Kilroy]

Greg I'm not interested in battling on an open forum. My first post said my documents were sometimes 70+ pages. And then I posted a "sample" of the clauses and I'm sorry (no I'm not) for asking if something above the original post was possible, your response at that time was not needed. Greg BTW I would never hire people who over react or try to place blame instead working through a problem. Thanks for you efforts to date but lets just call it Quits. I'll look elsewhere for an answer to my problem. Take care and good luck.

Regards

Kilroy

[gmaxey]

Over react? Other than attempting to help you, I don't think that I have reacted at all. I'm perfectly happy to call it quits. After all, I don't have the problem. You do. Good luck to you as well.

[gmaxey]

Kilroy,

If I didn't over react, perhaps I have been testy. I am not interested in open conflict with you either.

While perhaps I should have just called it quits and walked away, I went back and reviewed the string of postings to see if I could decipher specifically what you were trying to do since you wouldn't simply post a sample of an actual document properly formatted.

If you or someone else wants to use numbered headings (something like the following):

16710

Then this code might work. I certainly wouldn't work for you now and I don't want your money. However, two regular contributors here, and perfect strangers, have spent a considerable amount of time trying to help you. Perhaps you could make a donation equal to the value you feel you have received to some organization that helps other people with needs.


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As Range, oCellRng As Range
Dim lngRow As Long, lngIndex As Long
Dim oCell As Cell

Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).Range.Text = "Clause #"
.Cell(1, 2).Range.Text = "Section"
.Cell(1, 3).Range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.Range.Text) > 1 Then
oTbl.Rows.Add
For Each oCell In oTbl.Rows.Last.Cells
oCell.Range.Style = "Normal"
Next
If oPar.Range.ListFormat.ListType <> wdListNoNumbering Then
Set oCellRng = oTbl.Cell(oTbl.Rows.Count, 2).Range
With oCellRng
.End = .End - 1
.FormattedText = oPar.Range.FormattedText
.Characters.Last.Delete
.ListFormat.ConvertNumbersToText
.Collapse wdCollapseStart
Do Until .Characters.Last = vbTab
.MoveEnd wdCharacter, 1
Loop
.Delete
End With
Set oCellRng = oTbl.Cell(oTbl.Rows.Count, 1).Range
oCellRng.End = oCellRng.End - 1
oCellRng.Text = oPar.Range.ListFormat.ListString
oCellRng.Style = oTbl.Cell(oTbl.Rows.Count, 2).Range.Style
Else
Set oRng = oPar.Range
oRng.End = oRng.End - 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
End If
End If
DoEvents
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

I think you were right. You might have been testy and I think I'm the one who over reacted. I agree both you and Graham have donated time and I will donate as well. This last code is great. Works perfectly when all paragraph numbering is done using the numbering button. Is there a line I can substitute when the para numbers are simply typed?

[gmaxey]

Kilroy,

No harm, no foul.

I would suggest that you set the standard that numbered headings paragraphs must use style applied numbering and not try accommodate non-cooperative people. A line of code? No. However the previous code I posted should help you see how you could extract the numbered part of a manually typed number.

Lets say you want to push ahead and try to accommodate manual numbering and you use the previous code as a starting point. Well that works for ### tab Text. Surely some knucklehead will then com along and want to use ### space Text well then you see you have whole different situation to deal with.

[Kilroy]

Can anyone tell me why this macro only works on one paragraph? This code is great and was written by Greg. Thanks again Greg!!


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As range
Dim lngRow As Long, lngIndex As Long
Dim arrParts() As String
Dim bMainClause As Boolean
bMainClause = False
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).range.Text = "Clause #"
.Cell(1, 2).range.Text = "Section"
.Cell(1, 3).range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.range.Text) > 1 Then
oTbl.Rows.Add
If Not bMainClause Then
If IsNumeric(oPar.range.Characters(1)) Then
Set oRng = oPar.range
arrParts = Split(oPar.range.Text, Chr(9))
oTbl.Cell(oTbl.Rows.Count, 1).range.Text = arrParts(0)
oTbl.Cell(oTbl.Rows.Count, 1).range.ParagraphFormat.Alignment = wdAlignParagraphRight
oRng.End = oRng.End - 1
oRng.MoveStartUntil Cset:=vbTab
oRng.Start = oRng.Start + 1
oTbl.Cell(oTbl.Rows.Count, 2).range.FormattedText = oRng.FormattedText
bMainClause = True
End If
Else
If oPar.range.ListFormat.ListType = wdListSimpleNumbering Then
oTbl.Cell(oTbl.Rows.Count, 1).range.Text = oPar.range.ListFormat.ListString
Set oRng = oPar.range
oRng.End = oRng.End - 1
oTbl.Cell(oTbl.Rows.Count, 2).range.FormattedText = oRng.FormattedText
End If
End If
End If
DoEvents
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Because it was written by Greg to process the very specific sample text that you posted previously.

Once a paragraph (one paragraph and one paragraph only) which starts with a manually typed number is processed, bMainClause is set to true. Once that happens it stays true so no more paragraphs are processed. Do you know how to step trough code in the VB Editor using the F8 key? You should try it.

Again, please use the code tag when you post code.


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As Range
Dim lngRow As Long, lngIndex As Long
Dim arrParts() As String
Set oSource = ActiveDocument
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).Range.Text = "Clause #"
.Cell(1, 2).Range.Text = "Section"
.Cell(1, 3).Range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.Range.Text) > 1 Then
oTbl.Rows.Add
If IsNumeric(oPar.Range.Characters(1)) Then
Set oRng = oPar.Range
arrParts = Split(oPar.Range.Text, Chr(9))
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = arrParts(0)
oTbl.Cell(oTbl.Rows.Count, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
oRng.End = oRng.End - 1
oRng.MoveStartUntil Cset:=vbTab
oRng.Start = oRng.Start + 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
Else
If oPar.Range.ListFormat.ListType = wdListSimpleNumbering Then
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = oPar.Range.ListFormat.ListString
Set oRng = oPar.Range
oRng.End = oRng.End - 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
End If
End If
End If
DoEvents
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

This is so close to being perfect Greg. But for some reason it's still not copying paragraphs with no number, although it does appear to be creating the table line for them.

[Kilroy]

16718Please the attachment. This is the one I thought I attached last time for reference. dumb mistake on my part.

[gmaxey]

So where is the code that you say you are using in the document you attached?

[gmaxey]

Kilroy, Deleted.

[Kilroy]

Sub Auto_Format_convert_list_numbers()
'
' convert_list_numbers Macro
' Macro created 10/8/08 by WJ Shack
'
ActiveDocument.ConvertNumbersToText
End Sub

[Kilroy]

Sub RemoveLeadingTabs()
If ActiveDocument.range(0, 1).Text = vbTab Then
ActiveDocument.range(0, 1).Delete
End If
With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^p^w"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Sub

[Kilroy]

Kilroy, Deleted.

Deleted?

[gmaxey]

This processes your sample text:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oSource As Document, oTarget As Document
Dim oTbl As Table
Dim oPar As Paragraph
Dim oRng As Range, oCellRng As Range
Dim lngRow As Long, lngIndex As Long
Dim oCell As Cell
Dim arrParts() As String
Dim bUseSpace As Boolean
Set oSource = ActiveDocument
oSource.ConvertNumbersToText
With oSource.Range.Find
.Text = "^p^w"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
Set oTarget = Documents.Add
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 3)
With oTbl
.Columns(1).SetWidth ColumnWidth:=72, _
RulerStyle:=wdAdjustFirstColumn
.Cell(1, 1).Range.Text = "Clause #"
.Cell(1, 2).Range.Text = "Section"
.Cell(1, 3).Range.Text = "Comments"
End With
For lngRow = 1 To oSource.Paragraphs.Count
bUseSpace = False
Set oPar = oSource.Paragraphs(lngRow)
If Len(oPar.Range.Text) > 1 Then
oTbl.Rows.Add
For Each oCell In oTbl.Rows.Last.Cells
oCell.Range.Style = "Normal"
Next
If oPar.Range.ListFormat.ListType <> wdListNoNumbering Then
oPar.Range.ListFormat.ConvertNumbersToText
End If
Select Case True
Case IsNumeric(oPar.Range.Characters(1))
Set oRng = oPar.Range
arrParts = Split(oPar.Range.Text, Chr(9))
If UBound(arrParts) = 0 Then
bUseSpace = True
arrParts = Split(oPar.Range.Text, Chr(32))
End If
oTbl.Cell(oTbl.Rows.Count, 1).Range.Text = Trim(arrParts(0))
oTbl.Cell(oTbl.Rows.Count, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
oRng.End = oRng.End - 1
If bUseSpace Then
oRng.MoveStartUntil Cset:=Chr(32)
Else
oRng.MoveStartUntil Cset:=vbTab
End If
oRng.Start = oRng.Start + 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
Case Else
Set oRng = oPar.Range
oRng.End = oRng.End - 1
oTbl.Cell(oTbl.Rows.Count, 2).Range.FormattedText = oRng.FormattedText
End Select
DoEvents
End If
Next lngRow
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

Greg It's perfect. Thank you so much. I can't even explain how much this is going to help my everyday life. As I learn more about VBA I hope I'm able to help people like you've helped me.