删除EXCEL空白页

onthetrip

有些软件导入到EXCEL的时候会存在大量的空白页，此代码可以删除指定文件夹下所有EXCEL文件的空白页，附件是制作的加载宏。
1、VBA代码

1. Option Explicit
   
2. Sub rxbtnDelBlankPages_click(control As IRibbonControl)
   
3.     Dim MyPath As String '对话框选择的文件夹路径
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.     If .Show Then
   
6.         MyPath = .SelectedItems(1) & ""
   
7.         Call Recurison(MyPath)
   
8.     Else
   
9.         Exit Sub
   
10.     End If
    
11.     End With
    
12.     MsgBox "已完成"
    
13. End Sub
    
14. Private Sub Recurison(ByVal MyPath$)
    
15. Dim Wb As Workbook
    
16. Dim FSO As Object, MyFile As Object, MyFold As Object, SubMyFold As Object
    
17. Application.DisplayAlerts = False
    
18. Set FSO = CreateObject("scripting.FileSystemObject")
    
19. Set MyFold = FSO.getfolder(MyPath)
    
20. For Each MyFile In MyFold.Files
    
21.     If MyFile Like "*.xls*" Then '判断是否为EXCEL文件
    
22.         Set Wb = Workbooks.Open(MyFile)
    
23.         Call DelBlankPages(Wb)
    
24.         Wb.Close True
    
25.     End If
    
26. Next
    
27. For Each SubMyFold In MyFold.subfolders '递归
    
28.     Call Recurison(SubMyFold)
    
29. Next
    
30. Set FSO = Nothing
    
31. Application.DisplayAlerts = True
    
32. End Sub
    
33. Private Sub DelBlankPages(ByVal Wb As Workbook)
    
34. Dim Sht As Worksheet
    
35. Dim UnionRng As Range, PageRng As Range
    
36. Dim Cell1 As Range, Cell2 As Range
    
37. Dim HpageB As HPageBreak
    
38. Dim PageCount&, nMaxRow%, nMaxCol%
    
39. Dim i&
    
40. With Wb
    
41.     For Each Sht In .Worksheets
    
42.         Sht.Activate
    
43.         With ActiveSheet
    
44.             ActiveWindow.View = xlPageBreakPreview
    
45.             PageCount = .HPageBreaks.Count
    
46.             If PageCount > 0 Then '至少有两页才执行程序
    
47.                 If .PageSetup.PrintArea = "" Then '如果设置了打印区域，则以打印区域为最大行列
    
48.                     nMaxRow = 100: nMaxCol = 50
    
49.                 Else
    
50.                     nMaxRow = CInt(Split(.PageSetup.PrintArea, "$")(4))
    
51.                     nMaxCol = Range(Split(.PageSetup.PrintArea, "$")(3) & 1).Column
    
52.                 End If
    
53.                 For i = 1 To PageCount - 1
    
54.                     Set Cell1 = .HPageBreaks(i).Location
    
55.                     Set Cell2 = .HPageBreaks(i + 1).Location.Offset(-1, nMaxCol)
    
56.                     Set PageRng = Range(Cell1, Cell2)
    
57.                     If PageRng.Find("*") Is Nothing Then
    
58.                         Set PageRng = Range(Cell1, Cell2)
    
59.                             If UnionRng Is Nothing Then
    
60.                                 Set UnionRng = PageRng
    
61.                             Else
    
62.                                 Set UnionRng = Range(UnionRng, PageRng)
    
63.                             End If
    
64.                     End If
    
65.                 Next
    
66.                 '查找最后一个分页符之后的页面
    
67.                 nMaxRow = nMaxRow - .HPageBreaks(PageCount).Location.Row + 1
    
68.                 If .HPageBreaks(PageCount).Location.Resize(nMaxRow, nMaxCol).Find("*") Is Nothing Then
    
69.                     If UnionRng Is Nothing Then
    
70.                         Set UnionRng = .HPageBreaks(PageCount).Location.Resize(nMaxRow, 1)
    
71.                     Else
    
72.                         Set UnionRng = Range(UnionRng, .HPageBreaks(PageCount).Location.Resize(nMaxRow, 1))
    
73.                     End If
    
74.                 End If
    
75.                 If Not UnionRng Is Nothing Then
    
76.                     UnionRng.EntireRow.Delete
    
77.                     Set UnionRng = Nothing '置空变量
    
78.                 End If
    
79.             End If
    
80.         End With
    
81.     Next
    
82. End With
    
83. End Sub

复制代码

2、Ribbon。仅适用于2016以上版本，加载附件后会自动在功能区生成菜单。

1. <customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
   
2.     <ribbon startFromScratch="false">
   
3.         <tabs>
   
4.             <tab id="MyTools"
   
5.                  label="My Tools">
   
6.                         <group id="rxgrpDelBlankPages"
   
7.                         label="删除EXCEL文件空白页">
   
8.                         <button  id="rxbtnDelBlankPages"
   
9.                                  label="选择文件所在的文件夹"
   
10.                                  onAction="rxbtnDelBlankPages_click"
    
11.                                  size="large"
    
12.                                  imageMso="FileClose"/>
    
13.                  </group>
    
14.             </tab>
    
15.         </tabs>
    
16.     </ribbon>
    
17. </customUI>

复制代码