Estou tentando criar uma macro VBA para criar um documento do Word a partir do Excel ...
Atualmente, estou com problemas para configurar as listas corretamente. Eu quero os índices de lista vinculados aos meus dois tipos de cabeçalho.
Assim:
1. Header1
1.1. Header2
2. Header1
2.1 Header2
O problema é que minha lista de nível 2 não está sendo redefinida, embora eu tenha incluído a propriedade .ResetOnHigher. Isso significa que estou obtendo um resultado semelhante a este:
1. Header1
1.1. Header2
2. Header1
1.2 Header2
Alguém pode me dizer o que estou fazendo de errado e o que posso fazer para resolver esse problema?
Aqui está o código que estou usando:
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