# Word VBA give number to heading



## mrwad (Jan 29, 2019)

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 (Jan 29, 2019)

Instead of trying to do this through code, you should apply an appropriate numbering level to Word's Heading Styles and use those - a different one for each level. Your use of the same Heading Style for "main", "sub" and "sub-sub" militates against that. You should also not be overriding the formatting of whatever Styles you're using - define the Styles appropriately and use different Styles as needed. Moreover, since you're creating a document via Documents.Add, you can do all the Style setup in an appropriate template beforehand (and reference that via Documents.Add), thus obviating the need for any code to manage the Styles.


----------



## mrwad (Jan 29, 2019)

Macropod said:


> Instead of trying to do this through code, you should apply an appropriate numbering level to Word's Heading Styles and use those - a different one for each level. Your use of the same Heading Style for "main", "sub" and "sub-sub" militates against that. You should also not be overriding the formatting of whatever Styles you're using - define the Styles appropriately and use different Styles as needed. Moreover, since you're creating a document via Documents.Add, you can do all the Style setup in an appropriate template beforehand (and reference that via Documents.Add), thus obviating the need for any code to manage the Styles.



Thank you for your answer! Ok, then I will choose completely different strategy. I have tried this one also but can't get both bookmark and text to one embedded document but can't figure out how it is possible. 
The problem is that I need to get some text to header and footer. I can create Word template and insert it to Excel as an object. I can use predefined bookmarks to insert text from Excel to Word header and footer. Then I would like to use my code to insert text. How it is possible with code to firstly insert bookmarks and then exit header and footer and start to input the code? Also embedded Word template should be opened as a copy, as I do not want to make any changes to original file or null it with the code.

1) Open embedded Word document as a copy from Excel
2) Insert text from Excel to Word Bookmarks located in header and footer
3) Jump out of bookmark and start to input the text to Word document

Here is my code I came up with, but it is not doing 3 tasks mentioned above:


```
Sub opentemplateWord()
Dim sh As Shape
Dim objWord As Object ''Word.Document
Dim objOLE As OLEObject
Dim wSystem As Worksheet
Dim cell As Range


    Set wSystem = Worksheets("Templates")
''The shape holding the object from 'Create from file'
''Object 2 is the name of the shape
Set sh = wSystem.Shapes("Object 2")
''Activate the contents of the object
sh.OLEFormat.Activate
''The OLE Object contained
Set objOLE = sh.OLEFormat.Object
''This is the bit that took time
Set objWord = objOLE.Object


'>------- This Part Inputs Bookmarks
 
objWord.Bookmarks.Item("ProjectName1").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D15").Value
objWord.Bookmarks.Item("ProjectName2").Range.Text = ThisWorkbook.Sheets("MAIN").Range("D16").Value


'>------- This Part Inputs Text


  'ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '<--- This is for closing footer and header?


    With objWord '<--| 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")
                .TypeText Text:=cell.Offset(0, -1).Text
    Case "main"
                .TypeParagraph
                .Style = objWord.ActiveDocument.Styles("Heading 2")
                .TypeText Text:=cell.Offset(0, -1).Text


    Case "sub"
                .TypeParagraph
                .Style = objWord.ActiveDocument.Styles("Heading 3")
                .TypeText Text:=cell.Offset(0, -1).Text


    Case "sub-sub"
                .TypeParagraph
                .Style = objWord.ActiveDocument.Styles("Heading 4")
                .TypeText Text:=cell.Offset(0, -1).Text


                
    End Select
   Next cell
    End With


objWord.Application.Visible = False
 
''Easy enough
    objWord.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"


End Sub
```


----------



## mrwad (Jan 29, 2019)

Here is the link for example:
https://www29.zippyshare.com/v/omZZsL6D/file.html


----------



## Macropod (Jan 29, 2019)

If you're populating bookmarks, there is no need to access the page header as such - Word isn't concerned with where the bookmark is. As for not saving changes to the embedded object, you might try:

```
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("Offer 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 = 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 = 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
End With
End Sub
```


----------



## Macropod (Jan 29, 2019)

Now also cross-posted at: https://chandoo.org/forum/threads/e...rks-and-text-to-embedded-word-template.40788/
Please read Excel Forum's Cross-Posting policy in rule 8: http://www.excelforum.com/forum-rules/642590-forum-rules.html


----------



## mrwad (Jan 30, 2019)

Thanks for the code it seems to work pretty well. The only problem left to solve is to tell Word to jump to the end of the document. As now it is starting to input the text from the begging on top of my Cover page image and I would like it to do it starting from the last page.


----------



## Macropod (Jan 30, 2019)

Simply change:
Set wdRng = .Range(0, 0)
to:
Set wdRng = .Range.Characters.Last


----------



## mrwad (Jan 30, 2019)

That's awesome! Thank you!


----------



## mrwad (Jan 30, 2019)

One more question. What should I use to close Word template after code has done the job? 


```
wdUndo.EndCustomRecord  .Undo
   .Application.Quit
End With
End Sub
```

Does not seem to work. Getting a Word error: Microsoft Word has stopped working


----------



## mrwad (Jan 29, 2019)

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 (Jan 30, 2019)

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


----------



## mrwad (Jan 30, 2019)

I have deleted two unnecessary 

```
Set xlSht = Sheets("Main")
```
and added 

```
Set wdUndo = Nothing
```

now everything works!


----------



## Macropod (Jan 30, 2019)

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 (Feb 5, 2019)

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 (Feb 5, 2019)

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 (Feb 6, 2019)

Macropod said:


> 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
```


----------

