1

I'm trying to make a VBA macro to create a Word document from Excel...

Currently I'm having issues with setting up the Lists properly. I want the list indexes linked to my 2 header types.

Like so:

1. Header1
 1.1. Header2
2. Header1
 2.1 Header2

The problem is that my level 2 list is not resetting even though I've included the .ResetOnHigher property. This means I'm getting a result which looks like this:

1. Header1
 1.1. Header2
2. Header1
 1.2 Header2

Can someone tell me what I'm doing wrong and what can I do to resolve this issue?

Here is the code I'm using:

Option Explicit

Public WordApp As Word.Application
Public myDoc As Word.Document
Public WordTable As Word.Table


    Sub ToggleButton1_Click()

    'Optimize Code
      Application.ScreenUpdating = False
      Application.EnableEvents = False

    'Create an Instance of MS Word
      On Error Resume Next

    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")

    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")

    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

    On Error GoTo 0

    'Make MS Word Visible and Active
      WordApp.Visible = True
      WordApp.Activate

    'Create a New Document
      Set myDoc = WordApp.Documents.Add()


    Dim WS_Count, Table_Count As Integer
    Dim I As Integer
    Dim title As String

    'Format Text Styles              
    With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(1)
        .NumberFormat = "%1."
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = CentimetersToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(0.6)
        .TabPosition = wdUndefined
        .StartAt = 1
    End With

    With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(2)
        .NumberFormat = "%1.%2."
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = CentimetersToPoints(0.6)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = CentimetersToPoints(1)
        .TabPosition = wdUndefined
        .ResetOnHigher = 1
        .StartAt = 1
    End With

    With myDoc

        'Heading 1
            .Styles(wdStyleHeading1).Font.Name = "Arial"
            .Styles(wdStyleHeading1).Font.Size = 24
            .Styles(wdStyleHeading1).Font.Color = wdColorBlack
            .Styles(wdStyleHeading1).Font.Bold = True
            .Styles(wdStyleHeading1).ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
            .Styles(wdStyleHeading1).ParagraphFormat.SpaceAfter = 12
            .Styles(wdStyleHeading1).LinkToListTemplate _
                ListTemplate:=ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
                ListLevelNumber:=1

        'Heading 2
            .Styles(wdStyleHeading2).Font.Name = "Arial"
            .Styles(wdStyleHeading2).Font.Size = 18
            .Styles(wdStyleHeading2).Font.Color = wdColorBlack
            .Styles(wdStyleHeading2).Font.Bold = True
            .Styles(wdStyleHeading2).ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
            .Styles(wdStyleHeading2).ParagraphFormat.SpaceAfter = 12
            .Styles(wdStyleHeading2).LinkToListTemplate _
                ListTemplate:=ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
                ListLevelNumber:=2

        'Normal Style
            .Styles(wdStyleNormal).Font.Name = "Arial"
            .Styles(wdStyleNormal).Font.Size = 10
            .Styles(wdStyleNormal).Font.Color = wdColorBlack
            .Styles(wdStyleNormal).ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
            .Styles(wdStyleNormal).ParagraphFormat.SpaceAfter = 6

    End With

    'Setup Page header
    Call ExcelHeaderToWord(myDoc, ThisWorkbook.Worksheets(1).Range("Header"), 2)

    ' Set WS_Count equal to the number of worksheets in the active workbook.
    WS_Count = ActiveWorkbook.Worksheets.Count

    'Loop through sheets
    For I = 2 To WS_Count - 1

        'Check if sheet is to be included and if so past its content to word
        If ThisWorkbook.Worksheets(I).Shapes("Enable").OLEFormat.Object.Value = 1 = True Then

            'Insert Group Title if Group is different
            If ThisWorkbook.Worksheets(I).Cells(1, 1).Value = ThisWorkbook.Worksheets(I - 1).Cells(1, 1).Value = False Then
                myDoc.Paragraphs.Last.Range.Style = myDoc.Styles("Heading 1")
                myDoc.Paragraphs.Last.Range.Text = ThisWorkbook.Worksheets(I).Range("A1")
                myDoc.Paragraphs.Last.Range.InsertParagraphAfter
            End If

            'Insert Page Title
            myDoc.Paragraphs.Last.Range.Style = myDoc.Styles("Heading 2")
            myDoc.Paragraphs.Last.Range.Text = ThisWorkbook.Worksheets(I).Range("A2")
            myDoc.Paragraphs.Last.Range.InsertParagraphAfter

           'Insert Tables
            Call ExcelRangeToWord(myDoc, ThisWorkbook.Worksheets(I).Range("range1"), 1)
            myDoc.Paragraphs(myDoc.Paragraphs.Count).Range.InsertParagraph
            Call ExcelRangeToWord(myDoc, ThisWorkbook.Worksheets(I).Range("range2"), 2)
            myDoc.Paragraphs(myDoc.Paragraphs.Count).Range.InsertParagraph

            'Insert Page Break on last paragraph
            myDoc.Paragraphs.Last.Range.InsertBreak (wdPageBreak)

        End If
    Next I


    EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    'Clear The Clipboard
    Application.CutCopyMode = False

    End Sub

    Sub ExcelRangeToWord(myDoc As Word.Document, tbl As Excel.Range, fit As Integer)

    'Copy Excel Table Range
    tbl.Copy

    'Paste Table into MS Word
    myDoc.Paragraphs(myDoc.Paragraphs.Count).Range.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=False, _
        RTF:=False

    'Clear Clipboard
    Application.CutCopyMode = False

    'Autofit Last Table so it fits inside Word Document
    Set WordTable = myDoc.Tables(myDoc.Tables.Count)
    WordTable.AutoFitBehavior (fit)

    End Sub

    Sub ExcelHeaderToWord(myDoc As Word.Document, tbl As Excel.Range, fit As Integer)

    'Copy Excel Table Range
    tbl.Copy

    'Paste Table into MS Word
    myDoc.Sections(myDoc.Sections.Last.Index).Headers(wdHeaderFooterPrimary).Range.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=False, _
        RTF:=False

    'Clear Clipboard
    Application.CutCopyMode = False

    'Autofit Last Table so it fits inside Word Document
    Set WordTable = myDoc.Sections(myDoc.Sections.Last.Index).Headers(wdHeaderFooterPrimary).Range.Tables(myDoc.Sections(myDoc.Sections.Last.Index).Headers(wdHeaderFooterPrimary).Range.Tables.Count)
    WordTable.Spacing = 0
    WordTable.AutoFitBehavior (fit)

    End Sub

    Sub CheckBoxColor()

    'Check value of Include checkbox and change it's color accordingly
    If ActiveSheet.Shapes("Enable").OLEFormat.Object.Value = 1 = True Then
        ActiveSheet.Shapes("Enable").Fill.ForeColor.RGB = RGB(0, 255, 0)

    Else
        ActiveSheet.Shapes("Enable").Fill.ForeColor.RGB = RGB(255, 0, 0)

    End If

    End Sub
7
  • 1
    I don't see the code for the functions you're calling Oct 9, 2014 at 11:59
  • Didn't think it was important, they are not using any heading styles its just a function to copy an excel table to word. Oct 9, 2014 at 12:07
  • What do you mean? Its applying Header 1 where it should but then it resumes to header 2 without reseting it. Oct 9, 2014 at 12:14
  • Use F8 in the VBE and hover over the variables you're using to see when they are changing to the incorrect value. Oct 9, 2014 at 12:15
  • The variables are working fine, its the Lists method that isn't reseting when I use Header 1. Oct 9, 2014 at 12:20

1 Answer 1

1

Well i had the exact same Problem and it took me a whole day to solve it. The Thing is that you are creating the Styles and within each style you are pointing on the List+Listlevel. When you are using These Styles each Style is creating ist own List. So The Solution is to do it the other way round.

You have to create the new List template with all ist listlevels and within each Listlevel you have to Point on the Styles like:

ActiveDocument.ListTemplates("LT").ListLevels(1).LinkedStyle = "Style1"

And when you want to use this specific Format you insert it via:

.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:=ActiveDocument.ListTemplates("LT"), ContinuePreviousList:=True, ApplyLevel:=1

Have Fun =)

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .