|
本帖最后由 onthetrip 于 2020-2-14 10:46 编辑
有些软件导入到EXCEL的时候会存在大量的空白页,此代码可以删除指定文件夹下所有EXCEL文件的空白页,附件是制作的加载宏。
1、VBA代码
- Option Explicit
- Sub rxbtnDelBlankPages_click(control As IRibbonControl)
- Dim MyPath As String '对话框选择的文件夹路径
- With Application.FileDialog(msoFileDialogFolderPicker)
- If .Show Then
- MyPath = .SelectedItems(1) & ""
- Call Recurison(MyPath)
- Else
- Exit Sub
- End If
- End With
- MsgBox "已完成"
- End Sub
- Private Sub Recurison(ByVal MyPath$)
- Dim Wb As Workbook
- Dim FSO As Object, MyFile As Object, MyFold As Object, SubMyFold As Object
- Application.DisplayAlerts = False
- Set FSO = CreateObject("scripting.FileSystemObject")
- Set MyFold = FSO.getfolder(MyPath)
- For Each MyFile In MyFold.Files
- If MyFile Like "*.xls*" Then '判断是否为EXCEL文件
- Set Wb = Workbooks.Open(MyFile)
- Call DelBlankPages(Wb)
- Wb.Close True
- End If
- Next
- For Each SubMyFold In MyFold.subfolders '递归
- Call Recurison(SubMyFold)
- Next
- Set FSO = Nothing
- Application.DisplayAlerts = True
- End Sub
- Private Sub DelBlankPages(ByVal Wb As Workbook)
- Dim Sht As Worksheet
- Dim UnionRng As Range, PageRng As Range
- Dim Cell1 As Range, Cell2 As Range
- Dim HpageB As HPageBreak
- Dim PageCount&, nMaxRow%, nMaxCol%
- Dim i&
- With Wb
- For Each Sht In .Worksheets
- Sht.Activate
- With ActiveSheet
- ActiveWindow.View = xlPageBreakPreview
- PageCount = .HPageBreaks.Count
- If PageCount > 0 Then '至少有两页才执行程序
- If .PageSetup.PrintArea = "" Then '如果设置了打印区域,则以打印区域为最大行列
- nMaxRow = 100: nMaxCol = 50
- Else
- nMaxRow = CInt(Split(.PageSetup.PrintArea, "$")(4))
- nMaxCol = Range(Split(.PageSetup.PrintArea, "$")(3) & 1).Column
- End If
- For i = 1 To PageCount - 1
- Set Cell1 = .HPageBreaks(i).Location
- Set Cell2 = .HPageBreaks(i + 1).Location.Offset(-1, nMaxCol)
- Set PageRng = Range(Cell1, Cell2)
- If PageRng.Find("*") Is Nothing Then
- Set PageRng = Range(Cell1, Cell2)
- If UnionRng Is Nothing Then
- Set UnionRng = PageRng
- Else
- Set UnionRng = Range(UnionRng, PageRng)
- End If
- End If
- Next
- '查找最后一个分页符之后的页面
- nMaxRow = nMaxRow - .HPageBreaks(PageCount).Location.Row + 1
- If .HPageBreaks(PageCount).Location.Resize(nMaxRow, nMaxCol).Find("*") Is Nothing Then
- If UnionRng Is Nothing Then
- Set UnionRng = .HPageBreaks(PageCount).Location.Resize(nMaxRow, 1)
- Else
- Set UnionRng = Range(UnionRng, .HPageBreaks(PageCount).Location.Resize(nMaxRow, 1))
- End If
- End If
- If Not UnionRng Is Nothing Then
- UnionRng.EntireRow.Delete
- Set UnionRng = Nothing '置空变量
- End If
- End If
- End With
- Next
- End With
- End Sub
复制代码
2、Ribbon。仅适用于2016以上版本,加载附件后会自动在功能区生成菜单。
- <customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
- <ribbon startFromScratch="false">
- <tabs>
- <tab id="MyTools"
- label="My Tools">
- <group id="rxgrpDelBlankPages"
- label="删除EXCEL文件空白页">
- <button id="rxbtnDelBlankPages"
- label="选择文件所在的文件夹"
- onAction="rxbtnDelBlankPages_click"
- size="large"
- imageMso="FileClose"/>
- </group>
- </tab>
- </tabs>
- </ribbon>
- </customUI>
复制代码
|
|