Excel VBA code to updated Pagenumber in MS Word footer table

Vj3006

New Member
Joined
Jul 30, 2021
Messages
1
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi I am using Excel VBA code to updated Word document footer table information from excel. Its work fine only problem. I am unable to update page number properly in word. Kindly refer the below code I am using. Also below image is footer table I have in word.

It make page number but format is coming wrong . Refer below image.
Screenshot 2021-07-31 084228.jpg

"Uncontrolled When Printed & Chr(10)" come in cell (1,1) and page number come as "of 21" in cell(1,2) but i need "Uncontrolled When Printed & Chr(10) & "Page 1 of 2" . I tried my self but not able to success can you pls help me to get this format.

Correct format
Screenshot 2021-07-30 152421.jpg



VBA Code:
Sub Update_Informe_word_2003()
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdRng As Word.Range
    Dim j As Integer
    Dim datos(0 To 1, 0 To 30) As String '(columna,fila)
    Dim ruta As String
    Dim rngFooter As Word.Range
    Dim tbl As Word.Table
    Dim rngCell As Word.Range
    Dim FileName As String
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    
    
    For i = 2 To Application.WorksheetFunction.CountA(Range("A:A"))
    
    On Error GoTo nx:
    
    
    
    If Range("C" & i).Value = "Form (FORM)" Then
    logo = Range("s2").Value
    ruta = Range("s4").Value & "\Form\Word\" & Range("B" & i).Value & ".doc"
    
    FileName = VBA.FileSystem.Dir(ruta)
    If FileName = VBA.Constants.vbNullString Then GoTo nx
    
    Set wdDoc = wdApp.Documents.Open(ruta)
 

    Set rngFooter = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
    
    rngFooter.Delete
    
    With rngFooter
    
        Set tbl = rngFooter.Tables.Add(rngFooter, 1, 3)
'        tbl.Select
        With tbl.Borders
        .OutsideLineStyle = wdLineStyleSingle
        End With
        
        
        Set rngCell = tbl.Cell(1, 3).Range
        rngCell.Text = "Doc #: " & Range("e" & i).Value & Chr(10) & "Rev. #: " & Range("H" & i).Value
        rngCell.Font.Size = 7
        rngCell.Font.Name = "Arial"
        rngCell.Paragraphs.Alignment = wdAlignParagraphRight
    
        
        
        Set rngCell = tbl.Cell(1, 1).Range
        rngCell.Text = "Uncontrolled When Printed" & Chr(10) & "Page "

        rngCell.Collapse 0
        wdDoc.Fields.Add rngCell, wdFieldEmpty, "PAGE  \* Arabic", True
        rngCell.InsertAfter " of "
        rngCell.Collapse 0
        wdDoc.Fields.Add rngCell, wdFieldEmpty, "NUMPAGES  ", True
        rngCell.Font.Size = 7
        rngCell.Font.Name = "Arial"
        Set rngCell = tbl.Cell(1, 2).Range
        rngCell.Text = "VECTRUS COMPANY PROPRIETARY" & Chr(10) & "If Client Proprietary, Leave this Blank"
        rngCell.Font.Size = 7
        rngCell.Font.Name = "Arial"
        rngCell.Font.Bold = True

    End With
    
    'Set rngheader = wdDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
    
    'rngheader.Delete
    
    'Set tbl = rngheader.Tables.Add(rngheader, 1, 3)
    'Set rngCell = tbl.Cell(1, 1).Range
    'With rngCell
    '.InlineShapes.AddPicture FileName:=logo, LinkToFile:=False, SaveWithDocument:=True
    'End With

    Dim FindWord As String
    Dim result As String

rngFooter.Find.Execute FindText:="Doc #:", Forward:=True
If rngFooter.Find.Found = True Then rngFooter.Bold = True
    
Set rngFooter = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
    
    
rngFooter.Find.Execute FindText:="Rev. #: ", Forward:=True
If rngFooter.Find.Found = True Then rngFooter.Bold = True

Set rngFooter = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range

rngFooter.Find.Execute FindText:="Uncontrolled When Printed", Forward:=True
If rngFooter.Find.Found = True Then rngFooter.Bold = True

    Range("M" & i).Value = "Updated"

    wdDoc.Save
    wdDoc.Close
        End If
        
nx:
    Next
 Call Update_Informe_Excel_2003
 MsgBox ("Files updated")
End Sub


Kindly Help me to resolve.
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Try this macro.
VBA Code:
Sub Update_Informe_Word_2003()

    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim rngFooter As Word.Range
    Dim tbl As Word.Table
    Dim rngCell As Word.Range
    Dim fileName As String
    Dim logo As String
    Dim ruta As String
    Dim i As Long
    
    Set wdApp = New Word.Application 'CreateObject("Word.Application")
    wdApp.Visible = True
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row 'Application.WorksheetFunction.CountA(Range("A:A"))
    
        If Range("C" & i).Value = "Form (FORM)" Then
        
            logo = Range("S2").Value
            ruta = Range("S4").Value & "\Form\Word\" & Range("B" & i).Value & ".doc"
            
            FileName = VBA.FileSystem.Dir(ruta)
            
            If FileName <> VBA.Constants.vbNullString Then
            
                Set wdDoc = wdApp.Documents.Open(ruta)
                
                Set rngFooter = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
                With rngFooter
                    .Delete
                    Set tbl = .Tables.Add(rngFooter, 1, 3)
                    tbl.Borders.OutsideLineStyle = wdLineStyleSingle
                End With
                    
                Set rngCell = tbl.Cell(1, 3).Range
                With rngCell
                    .Text = "Doc #: " & Range("E" & i).Value & vbCr & "Rev. #: " & Range("H" & i).Value
                    .Font.Size = 7
                    .Font.Name = "Arial"
                    .Paragraphs.Alignment = wdAlignParagraphRight
                End With
                
                Set rngCell = tbl.Cell(1, 1).Range
                With rngCell
                    .Text = "Uncontrolled When Printed" & vbCr
                    .Font.Size = 7
                    .Font.Name = "Arial"
                    .Collapse wdCollapseEnd
                    .End = .End - 1   'needed, otherwise "Page " text is placed in next table cell
                End With
                                
                InsertText rngCell, "Page "
                InsertField rngCell, "PAGE \* Arabic"
                InsertText rngCell, " of "
                InsertField rngCell, "NUMPAGES"
                
                Set rngCell = tbl.Cell(1, 2).Range
                With rngCell
                    .Text = "VECTRUS COMPANY PROPRIETARY" & vbCr & "If Client Proprietary, Leave this Blank"
                    .Font.Size = 7
                    .Font.Name = "Arial"
                    .Font.Bold = True
                End With

                'Set rngheader = wdDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
                'rngheader.Delete
                'Set tbl = rngheader.Tables.Add(rngheader, 1, 3)
                'Set rngCell = tbl.Cell(1, 1).Range
                'With rngCell
                '   .InlineShapes.AddPicture FileName:=logo, LinkToFile:=False, SaveWithDocument:=True
                'End With
                    
                Dim FindWord As String
                Dim result As String
            
                rngFooter.Find.Execute FindText:="Doc #:", Forward:=True
                If rngFooter.Find.Found = True Then rngFooter.Bold = True
                
                Set rngFooter = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
                
                rngFooter.Find.Execute FindText:="Rev. #:", Forward:=True
                If rngFooter.Find.Found = True Then rngFooter.Bold = True
                
                Set rngFooter = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
            
                rngFooter.Find.Execute FindText:="Uncontrolled When Printed", Forward:=True
                
                If rngFooter.Find.Found = True Then rngFooter.Bold = True
            
                Range("M" & i).Value = "Updated"
            
                wdDoc.Save
                wdDoc.Close
            
            End If
            
        End If
            
    Next
    
    wdApp.Quit
    
    'Call Update_Informe_Excel_2003
    MsgBox "Files updated"
    
End Sub

Private Sub InsertText(rng As Word.Range, newText As String)

    rng.Text = newText
    rng.Collapse wdCollapseEnd

End Sub

Private Sub InsertField(rng As Word.Range, fieldText As String)
    
    Dim fld As Word.Field
    
    Set fld = rng.Document.Fields.Add(Range:=rng, Text:=fieldText, PreserveFormatting:=True)
    Set rng = fld.result
    rng.Collapse wdCollapseEnd
    rng.MoveStart wdCharacter, 1
    
End Sub
Result with Word 2019:
1627918510985.png
 
Upvote 0

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top