ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1018|回复: 0

[求助] excel vba 统一两个文档页脚页码使其连续不间断

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-7-6 07:40 | 显示全部楼层 |阅读模式
各位大师
各位老师:我想将两个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
                    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

请老师们指点指教,谢谢

两个文档统编页码.zip (26.2 KB, 下载次数: 4)



您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 07:48 , Processed in 0.041504 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表