Word VBA - Dynamic table creation based on Headings

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

Code:

---

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


---

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.

Thanks for your reply.

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

Code:

---

    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

---

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

Quote:

---

Originally Posted by macropod

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.

Try:

Code:

---

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

---