好友
阅读权限20
听众
最后登录1970-1-1
|
使用方法:
按 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 |
|