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]

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]

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]

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

 

[Macropod]

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]

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]

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]

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

 

[mrwad]

That's awesome! Thank you!

 

[mrwad]

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