吾爱破解 - 52pojie.cn

 找回密码
 注册[Register]

QQ登录

只需一步,快速开始

查看: 361|回复: 4
收起左侧

[经验求助] 求按打印页拆分excel工作表的方法或工具

[复制链接]
xvkong 发表于 2025-1-23 12:32
50吾爱币
如题,需要把一个工作簿中的很多工作表按打印页拆分,现在用的excel必备工具箱中的按打印页拆分功能,无法拆出工作表的最后一页,求求按打印页拆分excel工作表的方法或工具,或者解决无法拆分最后一页的方法

最佳答案

查看完整内容

使用方法: 按 Alt+F11 打开VBA编辑器 插入新模块并粘贴以上代码 运行宏 SplitWorksheetsByPrintPages 功能说明: 自动检测分页符:根据工作表的水平和垂直分页符拆分 保留格式:复制源区域的列宽、行高及单元格格式 自动命名:新工作表命名为"原表名_P1"、"原表名_P2"等 处理大数据:自动检测实际使用的数据区域 错误处理:自动删除已存在的同名工作表 注意事项: 请提前备份工作簿 确保分页符已正 ...

发帖前要善用论坛搜索功能,那里可能会有你要找的答案或者已经有人发布过相同内容了,请勿重复发帖。

elceric 发表于 2025-1-23 12:32
使用方法:
按 Alt+F11 打开VBA编辑器

插入新模块并粘贴以上代码

运行宏 SplitWorksheetsByPrintPages

功能说明:
自动检测分页符:根据工作表的水平和垂直分页符拆分

保留格式:复制源区域的列宽、行高及单元格格式

自动命名:新工作表命名为"原表名_P1"、"原表名_P2"等

处理大数据:自动检测实际使用的数据区域

错误处理:自动删除已存在的同名工作表

注意事项:
请提前备份工作簿

确保分页符已正确设置

工作表名称长度不要超过31个字符

拆分后的工作表将添加在原工作簿末尾

此代码将根据每个工作表的实际打印分页情况,将每个打印页的内容复制到独立的新工作表中,保留所有格式设置,适合需要按页处理Excel数据的场景。
下面是AI生成了一个简单的例子,总之就是那里错误,让AI调试那里,最终达成目的
Sub SplitWorksheetsByPrintPages()
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim hBreaks As Collection
    Dim vBreaks As Collection
    Dim hArray() As Long
    Dim vArray() As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long, j As Long, pageNum As Long
    Dim startRow As Long, endRow As Long
    Dim startCol As Long, endCol As Long
    Dim sourceRng As Range
    Dim hBreak As HPageBreak
    Dim vBreak As VPageBreak
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    For Each ws In ThisWorkbook.Worksheets
        ' 获取数据区域最后行列
        lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lastCol = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        
        ' 处理水平分页符
        Set hBreaks = New Collection
        For Each hBreak In ws.HPageBreaks
            hBreaks.Add hBreak.Location.Row
        Next hBreak
        hArray = GetSortedBreaks(hBreaks, lastRow)
        
        ' 处理垂直分页符
        Set vBreaks = New Collection
        For Each vBreak In ws.VPageBreaks
            vBreaks.Add vBreak.Location.Column
        Next vBreak
        vArray = GetSortedBreaks(vBreaks, lastCol)
        
        ' 拆分每个分页区间
        pageNum = 1
        For i = 0 To UBound(hArray) - 1
            startRow = hArray(i)
            endRow = hArray(i + 1) - 1
            For j = 0 To UBound(vArray) - 1
                startCol = vArray(j)
                endCol = vArray(j + 1) - 1
               
                ' 创建新工作表
                CreateNewWorksheet ws, pageNum, newWs
               
                ' 复制数据区域
                Set sourceRng = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol))
                sourceRng.Copy newWs.Range("A1")
               
                ' 调整格式
                AdjustFormatting ws, newWs, startRow, endRow, startCol, endCol
               
                pageNum = pageNum + 1
            Next j
        Next i
    Next ws
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "拆分完成!"
End Sub

' 获取排序后的分页符数组
Function GetSortedBreaks(breaks As Collection, lastLimit As Long) As Long()
    Dim tempArr() As Long
    Dim result() As Long
    Dim i As Long
   
    ' 转换为数组并排序
    If breaks.Count > 0 Then
        ReDim tempArr(0 To breaks.Count - 1)
        For i = 0 To breaks.Count - 1
            tempArr(i) = breaks(i + 1)
        Next i
        BubbleSort tempArr
    End If
   
    ' 构建结果数组
    ReDim result(0 To 0)
    result(0) = 1 ' 起始位置
    If breaks.Count > 0 Then
        For i = 0 To UBound(tempArr)
            ReDim Preserve result(0 To UBound(result) + 1)
            result(UBound(result)) = tempArr(i)
        Next i
    End If
    ReDim Preserve result(0 To UBound(result) + 1)
    result(UBound(result)) = lastLimit + 1 ' 结束位置
   
    GetSortedBreaks = result
End Function

' 冒泡排序
Sub BubbleSort(arr() As Long)
    Dim i As Long, j As Long
    Dim temp As Long
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
End Sub

' 创建新工作表并命名
Sub CreateNewWorksheet(originalWs As Worksheet, ByVal pageNum As Long, ByRef newWs As Worksheet)
    On Error Resume Next
    Set newWs = ThisWorkbook.Worksheets(originalWs.Name & "_P" & pageNum)
    If Err.Number = 0 Then
        Application.DisplayAlerts = False
        newWs.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    Set newWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    newWs.Name = originalWs.Name & "_P" & pageNum
End Sub

' 调整列宽和行高
Sub AdjustFormatting(originalWs As Worksheet, newWs As Worksheet, startRow As Long, endRow As Long, startCol As Long, endCol As Long)
    Dim c As Long, r As Long
    ' 调整列宽
    For c = 1 To (endCol - startCol + 1)
        newWs.Columns(c).ColumnWidth = originalWs.Columns(startCol + c - 1).ColumnWidth
    Next c
    ' 调整行高
    For r = 1 To (endRow - startRow + 1)
        newWs.Rows(r).RowHeight = originalWs.Rows(startRow + r - 1).RowHeight
    Next r
End Sub
elceric 发表于 2025-1-23 13:34
建议使用VBA试一试。AI直接写一段VBA代码执行就好了。再有,既然是无法拆分最后一页,也很简单,自己手动复制一页空表是否可行。
jyjjf 发表于 2025-1-23 19:09
你试试已经弄个无用的工作表在最后,这样无用的拆不拆就无所谓了
ORSSR 发表于 2025-1-23 21:44
Kutools for Excel: Excel 插件,提供了多个工具,包括“按页面拆分”功能,可以更轻松地分割工作表。
PDFCreator:如果您将工作表导出为 PDF 文件,可以使用此工具批量处理 PDF 文件,将其拆分为多页。
您需要登录后才可以回帖 登录 | 注册[Register]

本版积分规则

返回列表

RSS订阅|小黑屋|处罚记录|联系我们|吾爱破解 - LCG - LSG ( 京ICP备16042023号 | 京公网安备 11010502030087号 )

GMT+8, 2025-5-24 04:04

Powered by Discuz!

Copyright © 2001-2020, Tencent Cloud.

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