两个word文档连续编页码

xzh_yzcn

各位老师：我想将两个word的页码统一连续，请指教
文档1共7页，文档2共5页，即文档2从第8页开始，至12页
我编制了以下代码，但未能成功，请帮看一下，错在哪里，是否思路不对，或是那句代码写错了。谢谢
Sub 多文档页码统编A()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set wdapp = CreateObject("word.application")

MsgBox ("请选择确定需要页码统筹的文件所在文件夹！")
'用户指定目标文件夹路径
Set fld = Application.FileDialog(msoFileDialogFolderPicker) '选取并指定文件夹路径
With fld
    .Show
    ppath = .SelectedItems(1) ' 提取文件夹路径
End With

Set d = CreateObject("Scripting.Dictionary") '设置字典存放文件顺序
t = Dir(ppath & "\*.*")
d(t) = "" '也加入字典
Do Until t = ""
    t = Dir '依次读取文件
    d(t) = "" '加入字典
Loop

filearr = d.keys '从字典中取出遍历后文件名数组

'将文件夹中文件名数组排序，以便系统按排序后数组自动操作，以达到理想的效果
For i = 0 To UBound(filearr) - 1
For j = i + 1 To UBound(filearr) - 1
    t0 = Val(Split(filearr(i), "-")(0))
    t1 = Val(Split(filearr(j), "-")(0))
    If t0 > t1 Then
      s = filearr(i): filearr(i) = filearr(j): filearr(j) = s
    End If
Next j, i


With CreateObject("Scripting.FileSystemObject")  '引用FSO对象
    For i = 0 To UBound(filearr) - 1
'        Debug.Print File.Name
        If Right(filearr(i), 3) = "xls" Or Right(filearr(i), 4) = "xlsx" Or Right(filearr(i), 3) = "doc" Or Right(filearr(i), 4) = "docx" Then
            n = n + 1
'            ReDim Preserve filearr(1 To n)
            If Right(filearr(i), 3) = "doc" Or Right(filearr(i), 4) = "docx" Then
                '打开word文档
                '关键是要引用 Microsoft Word * Object Library，否则执行下句出错"要求对象"
                Set pwrdname = wdapp.Documents.Open(ppath & "\" & filearr(i))
                wdapp.Visible = True
                '统计word文档的页数
                If n = 1 Then
                    yms = wdapp.ActiveWindow.ActivePane.Pages.Count
                ElseIf n > 1 Then
                    myPages = yms
                    strfield = "第" & "=PAGE+" & myPages & "页"

                    CodesLenth = VBA.Len(strfield)
                    PageLenth = Len(CStr(myPages))
'                    Set wdDoc = Word.ActiveDocument 两个文档统编页码.zip (26.2 KB, 下载次数: 4)

2019-7-3 16:27 上传

点击文件名下载附件

                    With pwrdname
                        '添加页脚页码
'                       Set wdRange = pwrdname.Sections(1).Footers(wdHeaderFooterPrimary).Range
                        ‘上句执行错误，wdHeaderFooterPrimary为空值，请指点
                        wdRange.Text = strfield
                        wdRange.SetRange 2, 2 + 4
                        .Fields.Add Range:=wdRange, Type:=wdFieldEmpty, PreserveFormatting:=False
                        EndRange = wdRange.Paragraphs(1).Range.End - 2
                        wdRange.SetRange wdRange.Start - 1, EndRange
                        .Fields.Add Range:=wdRange, Type:=wdFieldEmpty, PreserveFormatting:=False
                        wdRange.Fields.Update
                        wdRange.Font.Size = 10
                        wdRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
                    End With
                    yms = yms + pwrdname.ComputeStatistics(Statistic:=wdStatisticPages, IncludeFootnotesAndEndnotes:=True) '页数
                End If
                pwrdname.Close True
            ElseIf Right(filearr(i), 3) = "xls" Or Right(filearr(i), 4) = "xlsx" Then
                '打开excel文档
                Workbooks.Open ppath & "\" & filearr(i)
                pfilename = ActiveWorkbook.Name
                '指定工作表
                Workbooks(pfilename).Activate
                If shtstr = "" Then
                    isqx = InputBox("请确定是否全选工作簿中的所有工作表，全部输入1，部分输入2", , 1)
                    If isqx = 1 Then
                        shtcount = ActiveWorkbook.Sheets.Count
                        For x = 1 To shtcount
                            If x = 1 Then
                                shtstr = Sheets(x).Name
                            ElseIf x > 1 Then
                                shtstr = shtstr & "," & Sheets(x).Name
                            End If
                        Next
                    ElseIf isqx = 2 Then
                        Application.ScreenUpdating = True
                        shtstr = Application.InputBox("请指定1个或多个工作表（中间用逗号“,”隔开，删除前面的等号", "", "sheet2", , , , , 64 + 2)
                        shtstr = Replace(shtstr, "=", "")
                        shtstr = Replace(shtstr, "'!", "")
                        shtstr = Replace(shtstr, "'", "")
                        shtstr = Replace(shtstr, "!", "")
                        shtstr = Replace(shtstr, "，", ",")
                        Application.ScreenUpdating = False
                    End If
'                Else:
'                    shtstr = Application.InputBox("请指定1个或多个工作表（中间用逗号“,”隔开，删除前面的等号", "", shtstr, , , , , 64 + 2)
                End If
                If InStr(shtstr, ",") >= 1 Then
                    brr = Split(shtstr, ",")
    '                yms = 4
                    For k = 0 To UBound(brr)
    '                    i = 6
                        Sheets(brr(k)).Select
    '                    Debug.Print Sheets(brr(i)).Name
                        ActiveSheet.PageSetup.FirstPageNumber = yms + 1
    '                    Debug.Print ActiveSheet.PageSetup.FirstPageNumber
                        yms = yms + ActiveSheet.PageSetup.Pages.Count
    '                    Debug.Print ActiveSheet.PageSetup.Pages.Count
                        '10为字号
                        ActiveSheet.PageSetup.CenterFooter = "&10第&P页"
                    Next
                Else:
                    Sheets(shtstr).Select
                    ActiveSheet.PageSetup.FirstPageNumber = yms + 1
                    yms = yms + ActiveSheet.PageSetup.Pages.Count
                    ActiveSheet.PageSetup.CenterFooter = "&10第&P页"
                End If
                Workbooks(pfilename).Close True
            End If
        End If
    Next
End With

wdapp.Quit

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

请老师们指点指教，谢谢