Metin Stili VBA makrosu MS Word'lü Numaralı Listeyi Sıfırla

Excel'den bir Word belgesi oluşturmak için bir VBA makrosu yapmaya çalışıyorum ...

Şu anda Listeleri doğru bir şekilde ayarlamakta sorun yaşıyorum. Liste başlıklarının 2 başlık tipime bağlı olmasını istiyorum.

Bunun gibi:

1. Header1
 1.1. Header2
2. Header1
 2.1 Header2

Sorun, seviye 2 listemin .ResetOnHigher özelliğini eklemiş olmama rağmen sıfırlanmamasıdır. Bu, şöyle görünen bir sonuç elde ettiğim anlamına gelir:

1. Header1
 1.1. Header2
2. Header1
 1.2 Header2

Birisi bana yanlış yaptığımı söyleyebilir mi ve bu sorunu çözmek için ne yapabilirim?

İşte kullanıyorum kodu:

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

Aynı problemi yaşadım ve çözmem bütün günümü aldı. Şey, Stilleri yaratıyor olmanız ve List + Listlevel üzerinde gösterdiğiniz her stilin içinde olmanızdır. Bu Stilleri kullanırken, her Stil kendi Listesini yaratır. Dolayısıyla, Çözüm bunu tam tersi şekilde yapmaktır.

Tüm liste düzeyleriyle birlikte yeni Liste şablonunu oluşturmalısınız ve her bir Liste Düzeyinde aşağıdaki gibi Stillere İşaret etmeniz gerekir:

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

Ve bu özel Formatı kullanmak istediğinizde şunu eklersiniz:

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

Eğlenin =)