Сброс нумерованного списка с помощью текстового стиля VBA macro MS Word

Question

Я пытаюсь сделать макрос VBA для создания документа Word из Excel ...

В настоящее время у меня возникают проблемы с правильной настройкой списков. Я хочу, чтобы индексы списка были связаны с моими 2 типами заголовков.

Вот так:

1. Header1
 1.1. Header2
2. Header1
 2.1 Header2

Проблема в том, что мой список уровня 2 не сбрасывается, хотя я включил.Свойство ResetOnHigher. Это означает, что я получаю результат, который выглядит следующим образом:

1. Header1
 1.1. Header2
2. Header1
 1.2 Header2

Может кто-нибудь сказать мне, что я делаю не так и что я могу сделать, чтобы решить эту проблему?

Вот код, который я использую:

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

Answer 1

Ну, у меня была точно такая же проблема, и мне потребовался целый день, чтобы ее решить. Дело в том, что вы создаете стили и внутри каждого стиля вы указываете на List+Listlevel. Когда вы используете эти стили, каждый стиль создает свой собственный список. Таким образом, решение состоит в том, чтобы сделать это наоборот.

Вы должны создать новый шаблон списка со всеми уровнями списка ist, и на каждом уровне списка вы должны указывать на стили, как:

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

И когда вы хотите использовать этот конкретный формат, вы вставляете его через:

,Спектр.ListFormat.ApplyListTemplateWithLevel ListTemplate:= ActiveDocument.ListTemplates("LT"), ContinuePreviousList:= True, ApplyLevel:= 1

Веселитесь =)