Excel VBA：在 Word 文件中生成页脚

Posted 2023-03-21

技术标签:

【中文标题】Excel VBA：在 Word 文件中生成页脚【英文标题】：Excel VBA: Generate Footer in WordFile 【发布时间】：2019-06-04 00:08:35 【问题描述】：

我使用 VBA 构建了一个 Excel 文件，您可以在其中生成目录并将正确的文档（Word 和 Excel 文件）放入正确的目录中。因此，当您执行代码（在 Excel 中）时，您首先必须选择您的根目标，然后创建所有目录。之后，它从模板文件夹中获取 Worddocuments，用 Excel 中的数据填充 Textmarks 并保存文件。这很好用，也感谢这个社区。p>

但现在的问题是：我无法正常工作，无法在 word-document 的页脚中填写新文件名。

这是目前完整功能的代码：

    Public Function Txtmkr_SDD()


    Dim appWord             As Object 'Word-Instance
    Dim wdDoc               As Object 'Word-Document
    Dim wdRngE              As Object 'Word-Range 1
    Dim wdRngR              As Object 'Word-Range 2
    Dim wdRngC              As Object 'Word-Range 3
    Dim wdRngCN             As Object 'Word-Range 4

    Dim wks                 As Worksheet 'Excel-Worksheet
    Dim AdresseCE           As String
    Dim neueAdresseCE       As Long
    Dim Processname1        As String
    Dim Processname2        As String
    Dim Version             As String

    '*** Word start ***
    Set appWord = CreateObject("Word.Application")

    '*** opens File ***
   Set wdDoc = appWord.Documents.Add(Template:=Worksheets("StartPage").Cells(48, 4) & "\Document_Templates\SDD_Template.dotx", NewTemplate:=False, DocumentType:=0)

    '*** Word visible ***
    appWord.Visible = True

    '*** just in case Document is protected ***
    'doc.Unprotect

    '*** Jump to Textmarker in Word ***
    '*** Check of existence ***
    '*** Take Value from "CopyData" Cell "B1" and insert Textmarker ***
    If wdDoc.Bookmarks.Exists("Processname1") Then
        With wdDoc.Bookmarks("Processname1")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(1, 2).Value
            wdDoc.Bookmarks.Add "Processname1", wdRngE
        End With
    Else
        MsgBox "Missing Link [Processname1]."
    End If

      '*** Take Value from "CopyData" Cell "B2" and insert Textmarker ***
    If wdDoc.Bookmarks.Exists("Processname2") Then
        With wdDoc.Bookmarks("Processname2")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(2, 2).Value
            wdDoc.Bookmarks.Add "Processname2", wdRngE
        End With
    Else
        MsgBox "Missing Link [Processname2]."
    End If


      If wdDoc.Bookmarks.Exists("Version") Then
        With wdDoc.Bookmarks("Version")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(3, 2).Value
            wdDoc.Bookmarks.Add "Version", wdRngE
        End With
    Else
        MsgBox "Missing Link [Version]."
    End If


          If wdDoc.Bookmarks.Exists("Create_Date") Then
        With wdDoc.Bookmarks("Create_Date")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(4, 2).Value
            wdDoc.Bookmarks.Add "Create_Date", wdRngE
        End With
    Else
        MsgBox "Missing Link [Create_Date]."
    End If


              If wdDoc.Bookmarks.Exists("Author") Then
        With wdDoc.Bookmarks("Author")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(6, 2).Value
            wdDoc.Bookmarks.Add "Author", wdRngE
        End With
    Else
        MsgBox "Missing Link [Author]."
    End If


   '*** Set Time_Date and SDD Path ***
    Dim time_date As String
    time_date = Format(Date, "yyyy_mm_dd")
    Dim SDD As String

    '*** Define SDD as RegularPath ***
    SDD = (time_date & "_" & Worksheets("CopyData").Cells(1, 2).Value & "_" & Worksheets("CopyData").Cells(21, 2).Value & "_" & Worksheets("Helper#3").Cells(3, 2).Value & "_" & "V" & Worksheets("CopyData").Cells(3, 2).Value & ".docx")

    '*** Dim wdApp As Word.Application ***
    Set wdApp = GetObject(, "Word.Application")
    '*** Set up SavePath & Filename ***
    appWord.ActiveDocument.SaveAs Worksheets("Variables").Cells(3, 8).Value & "\" & (Worksheets("Setup#2_DirectoryList").Cells(1, 1)) & "\" & Worksheets("Setup#2_DirectoryList").Cells(3, 3).Value & "\" & Worksheets("Setup#2_DirectoryList").Cells(14, 21).Value & "\" & SDD

    '*** Word quit ***
    appWord.ActiveDocument.Close
    appWord.Quit

    '*** disable Variables ***
    Set wdRngE = Nothing
    Set wdRngR = Nothing
    Set wdRngC = Nothing
    Set wdRngCN = Nothing
    Set wdRng = Nothing
    Set wdDoc = Nothing
    Set appWord = Nothing
    Set sFolder = Nothing

End Function

如果有人可以帮助我，那就太好了:-)

【问题讨论】：

你不能只在模板的页脚中包含文件名吗？ 【参考方案1】：

只需在模板的页脚中放置一个 FILENAME 字段。这样，您就不需要代码来做同样的事情。相反，您需要做的（保存文件后）就是使用：

Application.ScreenUpdating = False
With ActiveDocument
  .Fields.Update
  .PrintPreview
  .ClosePrintPreview
End With
Application.ScreenUpdating = True

然后重新保存以使字段更新“粘”。

【讨论】：

【参考方案2】：

感谢marcroprod，问题得以解决。对于有类似问题的每个人，这里是完整的代码：

Public Function Txtmkr_SDD()


    Dim appWord             As Object 'Word-Instance
    Dim wdDoc               As Object 'Word-Document
    Dim wdRngE              As Object 'Word-Range 1
    Dim wdRngR              As Object 'Word-Range 2
    Dim wdRngC              As Object 'Word-Range 3
    Dim wdRngCN             As Object 'Word-Range 4

    Dim wks                 As Worksheet 'Excel-Worksheet
    Dim AdresseCE           As String
    Dim neueAdresseCE       As Long
    Dim Processname1        As String
    Dim Processname2        As String
    Dim Version             As String

    '*** Word start ***
    Set appWord = CreateObject("Word.Application")

    '*** opens File ***
   Set wdDoc = appWord.Documents.Add(Template:=Worksheets("StartPage").Cells(48, 4) & "\Document_Templates\SDD_Template.dotx", NewTemplate:=False, DocumentType:=0)

    '*** Word visible ***
    appWord.Visible = True

    '*** just in case Document is protected ***
    'doc.Unprotect

    '*** Jump to Textmarker in Word ***
    '*** Check of existence ***
    '*** Take Value from "CopyData" Cell "B1" and insert Textmarker ***
    If wdDoc.Bookmarks.Exists("Processname1") Then
        With wdDoc.Bookmarks("Processname1")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(1, 2).Value
            wdDoc.Bookmarks.Add "Processname1", wdRngE
        End With
    Else
        MsgBox "Missing Link [Processname1]."
    End If

      '*** Take Value from "CopyData" Cell "B2" and insert Textmarker ***
    If wdDoc.Bookmarks.Exists("Processname2") Then
        With wdDoc.Bookmarks("Processname2")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(2, 2).Value
            wdDoc.Bookmarks.Add "Processname2", wdRngE
        End With
    Else
        MsgBox "Missing Link [Processname2]."
    End If


      If wdDoc.Bookmarks.Exists("Version") Then
        With wdDoc.Bookmarks("Version")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(3, 2).Value
            wdDoc.Bookmarks.Add "Version", wdRngE
        End With
    Else
        MsgBox "Missing Link [Version]."
    End If


          If wdDoc.Bookmarks.Exists("Create_Date") Then
        With wdDoc.Bookmarks("Create_Date")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(4, 2).Value
            wdDoc.Bookmarks.Add "Create_Date", wdRngE
        End With
    Else
        MsgBox "Missing Link [Create_Date]."
    End If


              If wdDoc.Bookmarks.Exists("Author") Then
        With wdDoc.Bookmarks("Author")
            Set wdRngE = .Range
            wdRngE.Text = Worksheets("CopyData").Cells(6, 2).Value
            wdDoc.Bookmarks.Add "Author", wdRngE
        End With
    Else
        MsgBox "Missing Link [Author]."
    End If


   '*** Set Time_Date and SDD Path ***
    Dim time_date As String
    time_date = Format(Date, "yyyy_mm_dd")
    Dim SDD As String

    '*** Define SDD as RegularPath ***
    SDD = (time_date & "_" & Worksheets("CopyData").Cells(1, 2).Value & "_" & Worksheets("CopyData").Cells(21, 2).Value & "_" & Worksheets("Helper#3").Cells(3, 2).Value & "_" & "V" & Worksheets("CopyData").Cells(3, 2).Value & ".docx")

    '*** Dim wdApp As Word.Application ***
    Set wdApp = GetObject(, "Word.Application")
    '*** Set up SavePath & Filename ***
    appWord.ActiveDocument.SaveAs Worksheets("Variables").Cells(3, 8).Value & "\" & (Worksheets("Setup#2_DirectoryList").Cells(1, 1)) & "\" & Worksheets("Setup#2_DirectoryList").Cells(3, 3).Value & "\" & Worksheets("Setup#2_DirectoryList").Cells(14, 21).Value & "\" & SDD

    '*** Updating the Footer of the Document ***
    Application.ScreenUpdating = False
    With appWord.ActiveDocument
        .Fields.Update
        .PrintPreview
        .ClosePrintPreview
    End With
    Application.ScreenUpdating = True

    appWord.ActiveDocument.Save


    '*** Word quit ***
    appWord.ActiveDocument.Close
    appWord.Quit

    '*** disable Variables ***
    Set wdRngE = Nothing
    Set wdRngR = Nothing
    Set wdRngC = Nothing
    Set wdRngCN = Nothing
    Set wdRng = Nothing
    Set wdDoc = Nothing
    Set appWord = Nothing
    Set sFolder = Nothing

End Function

【讨论】：

以上是关于Excel VBA：在 Word 文件中生成页脚的主要内容，如果未能解决你的问题，请参考以下文章

使用 Excel VBA 宏在 Word 中查找和替换页脚文本

Word VBA：转换页脚/页眉中的上标

Excel VBA操作word文件

如何使用 VBA 将页码字段逻辑插入 Word 模板的页脚？

如何用EXCEL的VBA控制WORD文档？

防止 Word VBA 中的 Excel 提示