Word VBA give number to heading

[mrwad]

How it is possible for every "main", "sub" and "sub-sub" Cases set number before Heading. Numbers should be entered starting from one.

    Main  ->  1 
    Main  ->  2
    Sub  ->   2.1
    Sub  ->   2.2
    Sub-Sub -> 2.2.1
    Sub-Sub -> 2.2.2
    Sub-Sub -> 2.2.3
    Main  ->  3
    Main  ->  4
    Sub  ->   4.1


Main -> `.Font.Bold = True` 


Sub -> `.Font.Bold = True`

For numbering I guess it possible to apply Numbering for "Heading 2" at the end of the code something like `objDoc.Range.Font.ColorIndex = wdBlack`? What code should I use for that? I have been exploring internet for 2 hours and couldn't find any suitable.


Here is my full code:

    Option Explicit
    
    Sub main()
    
        Dim objWord As Object
        Dim objDoc As Object
        Dim objSelection As Object
        Dim cell As Range
    
        Set objWord = CreateObject("Word.Application") '<--| get a new instance of Word
        Set objDoc = objWord.Documents.Add '<--| add a new Word document
        objWord.Visible = True
        Set objSelection = objDoc.ActiveWindow.Selection '<--| get new Word document 'Selection' object
    
        With objSelection '<--| reference 'Selection' object
    
    For Each cell In ThisWorkbook.Worksheets("Offer Letter").Range("C1", ThisWorkbook.Worksheets("Offer Letter").Range("C" & Rows.Count).End(xlUp))
         Select Case LCase(cell.Value)
        Case "title"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Heading 1")
                    '.ActiveDocument.Font.Bold = True
                    .TypeText Text:=cell.Offset(0, -1).Text
                    .ParagraphFormat.SpaceAfter = 20
                    .ParagraphFormat.SpaceBefore = 20
        Case "main"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Heading 2")
                    .TypeText Text:=cell.Offset(0, -1).Text
    
        Case "sub"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Heading 2")
                    .TypeText Text:=cell.Offset(0, -1).Text
    
        Case "sub-sub"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Heading 2")
                    .TypeText Text:=cell.Offset(0, -1).Text
    
        Case "contact"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Normal")
                    .TypeText Text:=cell.Offset(0, -1).Text
                    .ParagraphFormat.SpaceAfter = 0
    
        Case "par"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Normal")
                    .TypeText Text:=cell.Offset(0, -1).Text
    
        Case "attachment"
                    .TypeParagraph
                    .Style = objWord.ActiveDocument.Styles("Normal")
                    .TypeText Text:=cell.Offset(0, -1).Text
                    .ParagraphFormat.SpaceAfter = 0
    
          End Select
          
       Next cell
       
               objDoc.Range.Font.Name = "Arial"
               objDoc.Range.Font.ColorIndex = wdBlack
    
        End With
    
        objDoc.SaveAs2 ActiveWorkbook.Path & "\" & Sheets("Other Data").Range("AN2").Value & ", " & Sheets("Other Data").Range("AN7").Value & "_" & Sheets("Other Data").Range("AN8").Value & "_" & Sheets("Other Data").Range("AX2").Value & ".docx" '<--| save your word document
    
        objWord.Quit '<--| quit Word
        Set objWord = Nothing '<--| release object variable
    End Sub

https://stackoverflow.com/questions...nt-bold?noredirect=1#comment95634132_54406888

 

[Macropod]

Try:
objOLE.Application.Quit
or:
sh.OLEFormat.Object.Application.Quit

 

[mrwad]

I have deleted two unnecessary

Set xlSht = Sheets("Main")

and added

Set wdUndo = Nothing

now everything works!

 

[Macropod]

Yet another cross-post: https://stackoverflow.com/questions...-text-and-bookmarks-to-embedded-word-template
This is getting tiresome. If you're not going to abide by our cross-posting rules, your posting privileges here may be curtailed.

 

[mrwad]

This one runs for the first time good but after trying to run the code from Excel for the second time it opens Word template, writes in it and saving document to desired destination but then you receive "Microsoft Word has stopped working", "Windows can try o recover your information". "Close the program". Any ideas on how to repair this one?

I have tried

TrybjOLE.Application.Quit
or:
sh.OLEFormat.Object.Application.Quit

but by this commands Excel is trying to close Excel document.

Sub opentemplateWord()
Dim sh As Shape
Dim objOLE As OLEObject
Dim objWord As Object 'Word.Document
Dim wdRng As Object 'Word.Range
Dim wdUndo As Object 'Word.UndoRecord
Dim cell As Excel.Range
Dim xlRng As Excel.Range
Dim xlSht As Worksheet




Set xlSht = Sheets("Letter")


With xlSht
  Set xlRng = .Range("C1", .Range("C" & Rows.Count).End(xlUp))
End With


''The shape holding the object from 'Create from file'
''Object 2 is the name of the shape
Set sh = Worksheets("Templates").Shapes("Object 2")
''Activate the contents of the object
sh.OLEFormat.Activate
Set objOLE = sh.OLEFormat.Object
Set objWord = objOLE.Object


With objWord
  Set wdRng = .Range(0, 0)
  Set wdUndo = .Application.UndoRecord
  wdUndo.StartCustomRecord ("Doc Data")
Set xlSht = Nothing
  Set xlSht = Sheets("MAIN")
  .Bookmarks("ProjectName1").Range.Text = xlSht.Range("D15").Value
  .Bookmarks("ProjectName2").Range.Text = xlSht.Range("D16").Value


  For Each cell In xlRng
    wdRng.InsertAfter vbCr & cell.Offset(0, -1).Text
     Select Case LCase(cell.Value)
        Case "title"
          wdRng.Paragraphs.Last.Style = .Styles("Heading 1")
        Case "main"
          wdRng.Paragraphs.Last.Style = .Styles("Heading 2")
        Case "sub"
          wdRng.Paragraphs.Last.Style = .Styles("Heading 3")
        Case "sub-sub"
          wdRng.Paragraphs.Last.Style = .Styles("Heading 4")
    End Select
  Next cell
Set xlSht = Nothing
  Set xlSht = Sheets("Other Data")
  .SaveAs2 ActiveWorkbook.Path & "\" & _
    xlSht.Range("AN2").Value & ", " & _
    xlSht.Range("AN7").Value & "_" & _
    xlSht.Range("AN8").Value & "_" & _
    xlSht.Range("AX2").Value & ".docx"
  wdUndo.EndCustomRecord
  .Undo
Set wdUndo = Nothing

End With
Set objWord = Nothing

End Sub

Trying to solve it also here: https://stackoverflow.com/questions...nto-one?noredirect=1#comment95865938_54528949

 

[Macropod]

The first thing to try is quitting Windows & re-starting. If that doesn't fix things, try repairing the Office installation (via Windows Control Panel > Programs > Programs & Features > Microsoft Office (version) > Change > Repair).

 

[mrwad]

The first thing to try is quitting Windows & re-starting. If that doesn't fix things, try repairing the Office installation (via Windows Control Panel > Programs > Programs & Features > Microsoft Office (version) > Change > Repair).

I have tried to do this on several Widows machines with the same result so don't think the problem is in Windows installation. I have tried to restart computer as well.

If I set two of the same codes in a row and create separate macro for example called "AllTogether" then run each macro from "AllTogether" by "Call", debugger points to an error on second

sh.OLEFormat.Activate