为Word文档添加页码后将全量数据导入Excel的实现方法

原有Word导入Excel的逻辑、所有内置标识符、变量名完全保留，仅做两处必要补充即可实现「先为Word添加页码、再导入内容到Excel」的需求：

• 调整文档打开权限：将原代码中打开Word的参数ReadOnly:=True修改为ReadOnly:=False，否则无法执行插入页码的操作
• 新增页码插入逻辑：在文档打开激活后、复制内容前，自动为文档所有页面的页脚居中位置添加阿拉伯数字格式页码；代码关闭Word时会直接丢弃所有改动，不会修改本地存储的原Word文件

完整修改后代码 #

Sub ImportWord()
    'UpdatebyExtendoffice20190530
    Dim xObjDoc As Object
    Dim xWdApp As Object    
    Dim xWdName As Variant    
    Dim xWb As Workbook    
    Dim xWs As Worksheet    
    Dim xName As String    
    Dim xPC, xRPP
    
    Application.ScreenUpdating = False    
    Application.DisplayAlerts = False
    
    xWdName = Application.GetOpenFilename("Word file(*.doc;*.docx) ,*.doc;*.docx", , "Kutools - Please select")    
    If xWdName = False Then Exit Sub
    
    Application.ScreenUpdating = True
    
    Set xWb = Application.ActiveWorkbook    
    Set xWs = xWb.Worksheets.Add    
    Set xWdApp = CreateObject("Word.Application")
    
    xWdApp.ScreenUpdating = True    
    xWdApp.DisplayAlerts = True
    
    ' 修改：关闭只读模式，支持插入页码
    Set xObjDoc = xWdApp.Documents.Open(Filename:=xWdName, ReadOnly:=False)
    xObjDoc.ActiveWindow.ActivePane.View.Type = 1    
    xObjDoc.Activate

    ' 新增：自动为文档添加居中页脚页码
    With xObjDoc.Sections(1).Footers(1)
        .PageNumbers.Add PageNumberAlignment:=1, FirstPage:=True
        .PageNumbers.NumberStyle = 0
    End With

    xPC = xObjDoc.Paragraphs.Count    
    Set xRPP = xObjDoc.Range(Start:=xObjDoc.Paragraphs(1).Range.Start, End:=xObjDoc.Paragraphs(xPC).Range.End)    
    xRPP.Select
    
    On Error Resume Next
    
    xWdApp.Selection.Copy    
    xName = xObjDoc.Name    
    xName = Replace(xName, ":", "_")    
    xName = Replace(xName, "\", "_")    
    xName = Replace(xName, "/", "_")    
    xName = Replace(xName, "?", "_")    
    xName = Replace(xName, "*", "_")    
    xName = Replace(xName, "[", "_")    
    xName = Replace(xName, "]", "_")
    
    If Len(xName) > 31 Then    
        xName = Left(xName, 31)    
    End If
    
    xWs.Name = xName    
    xWs.Range("A1").Select
    xWs.Paste
    
    'If something goes wrong, go to the errorhandler
    On Error GoTo ERRORHANDLER
    'Checks the document for excessive spaces between words
    
    xObjDoc.Close    
    Set xObjDoc = Nothing    
    xWdApp.DisplayAlerts = True    
    xWdApp.ScreenUpdating = True    
    xWdApp.Quit (wdDoNotSaveChanges)    
    Application.DisplayAlerts = True    
    Application.ScreenUpdating = True    
End Sub

注：如果需要调整页码位置，可修改PageNumberAlignment参数值：0为左对齐、1为居中、2为右对齐；如果不需要首页显示页码，将FirstPage:=True改为FirstPage:=False即可。

内容的提问来源于stack exchange，提问作者Djaa