Word VBA - Dynamic table creation based on Headings

[Saetheer]

Hi,
First: I'm not looking for a table of content. Not like the one Word offers at least.

My document format looks some kind like this: underlined text is the "name" of the chapter, you might say, and is the actual text I want to populate a table with.
Heading 1: Unique name (actually in number format).
Heading 2: The actual name (underline) contain the text I want.
Heading 3: Actual data. in a number list

Heading 1 Experiment #1
Heading 2 Critical

Heading 3 Item 1.1
Heading 3 Item 1.2

Heading 2 Deviations


Heading 3 Item 2.1


Heading 3 Item 2.2

Heading 2 Remark

Heading 3 Item 3.1
Heading 3 Item 3.2




From this, I want a table (with dynamic length, based on number of heading 1's).
Note that Experiement #2 dont have any ciritcal items in this example.



Experiment
type
Text


Experiment #1
Critical

Item 1.1
Item 1.2



Deviations


Item 2.1
Item 2.2



Remark


Item 3.1
Item 3.2


Experiment #2
Deviations


Item 2.1
Item 2.2



Remark
Item 3.1
Item 3.2




Appreciate any help anyone can provide some helpfull insight, even better if anyone has code for this.

I want to create a table, to make a summary
The psudo code, in my head


H1_Count = ThisDocument.Heading1.Count()
iCol = 3; // 3 columns
iRow = H1_Count +1 // Heading 1 count + header
Table = CreateTable(iCol, iRow)
row = Table.AddRow()
row(0,"Experiment")
row(1,"Type")
row(2,"Text")
foreach H1 in ThisDocument:
row = Table.AddRow()
row(0,H1.Text) // first column filled with experiment #
foreach H2 in ThisDocument:
row(1,H2.Text) // second column filled with Critical/Deviation/Remarks
foreach H3 in ThisDocument:
row(2,H3.Text) // third column filled with all items

[macropod]

The simplest way would be to have your macro create a normal Word Table of Contents (without page #s), convert that to text, replace the relevant paragraph breaks with tabs, then convert the lot to a Word table.

[Saetheer]

Thanks for your reply.

My code just leaves the TOC in plain text in cell (0,0)


ThisDocument.Tables(1).Delete ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=4, NumColumns:=3

Set myRange = Selection.Range
ActiveDocument.TablesOfContents.Add _
Range:=myRange, _
UseFields:=False, _
UseHeadingStyles:=True, _
IncludePageNumbers:=False, _
LowerHeadingLevel:=3, _
UpperHeadingLevel:=1, _
AddedStyles:="myStyle, yourStyle"

For Each nextTOC In ActiveDocument.TablesOfContents
nextTOC.Range.Fields.Unlink
Next

[macropod]

Since you're not doing as I suggested, it's hardly surprising you're having problems.

[Saetheer]

Since you're not doing as I suggested, it's hardly surprising you're having problems.
Elaborate please? I'm not the best vba programmer. It sounds like you're suggeting this is a piece of cake.

[macropod]

Try:

Sub Make_Table()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, Para As Paragraph
With ActiveDocument
.TablesOfContents.Add Range:=.Range(0, 0), UseHeadingStyles:=True, IncludePageNumbers:=False
Set Rng = .TablesOfContents(1).Range
With Rng
.Fields.Unlink
For Each Para In .Paragraphs
Select Case Para.Style
Case "TOC 2"
If Para.Range.Previous.Style = "TOC 2" Then Para.Range.InsertBefore vbTab & vbTab
If Para.Range.Previous.Style = "TOC 3" Then Para.Range.InsertBefore vbTab
Case "TOC 3"
If Para.Range.Previous.Style = "TOC 1" Then Para.Range.InsertBefore vbTab
If Para.Range.Previous.Style = "TOC 3" Then Para.Range.InsertBefore vbTab & vbTab
End Select
Next
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Wrap = wdFindStop
.Text = "^p"
.Replacement.Text = "^t"
.Style = "TOC 1"
.Execute Replace:=wdReplaceAll
.Style = "TOC 2"
.Execute Replace:=wdReplaceAll
End With
.Style = wdStyleNormal
.Font.Reset
.ConvertToTable Separator:=vbTab, Numcolumns:=3
End With
End With
Application.ScreenUpdating = True
End Sub