删除空白页，熟悉WORD VBA的老师帮看下

aman1516 · 发表于 2022-5-17 22:13

删除空白页
https://club.excelhome.net/thread-1627765-1-1.html

WOED版块看来应用到VBA的明显是少于EXCEL，WROD 好多问题涉VBA 得到解答都少
WORD一些数据处理与EXCEL表格还是区别较大，本人也不算熟，哪位老师移步帮忙看下，免得重复发贴了

蓝桥玄霜 · 发表于 2022-5-18 08:55

加一个判断：

Sub delpage()
Const wdPageBreak = 7
Const wdSectionBreakContinuous = 3
Const wdSectionBreakNextPage = 2
Const wdGoToPage = 1
Const wdGoToAbsolute = 1
Dim oDoc As Document
Dim oRng As Range
Set oDoc = Word.ActiveDocument
Dim iPageNo As Long
With oDoc
iPageNo = .Range.Information(wdNumberOfPagesInDocument)
For i = iPageNo To 1 Step -1
Set oRng = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=i)
oRng.Select
oRng.SetRange oRng.Start, oRng.Bookmarks("\page").End
sText = oRng.Text
If oRng.Tables.Count = 0 And oRng.InlineShapes.Count = 0 Then
If Not (sText Like "*[0-9]*" Or sText Like "*[a-z]*" Or sText Like "*[A-Z]*" Or sText Like "*[一-龥]*") Then
oRng.Delete
End If
End If
Next i
End With
End Sub

复制代码

aman1516 · 发表于 2022-5-18 10:50

多谢谢版主出手，经测试，运行一次时，差最后一页未能删除（有多个回车符空行）
再执行一次，才能把最一页删除了

cjc209 · 发表于 2022-5-18 11:18

蓝桥玄霜发表于 2022-5-18 08:55
加一个判断：

很难得版主帖可复制的代码出来谢谢版主的无私奉献

aman1516 · 发表于 2022-5-18 11:29

自己也学着鼓捣一下，未优化：

Sub DelPage()
Dim Pn As Long, Rng As Range, P As Integer
Pn = ThisDocument.BuiltInDocumentProperties(wdPropertyPages)
For P = 1 To Pn
If P = Pn Then
Set Rng = ThisDocument.Range(Start:=ThisDocument.GoTo(wdGoToPage, wdGoToAbsolute, P).Start)
Else
Set Rng = ThisDocument.Range(Start:=ThisDocument.GoTo(wdGoToPage, wdGoToAbsolute, P).Start, End:=ThisDocument.GoTo(wdGoToPage, wdGoToAbsolute, P + 1).Start)
End If
If Replace(Rng.Text, Chr(13), "") = "" Or Replace(Rng.Text, Chr(13), "") = Chr(12) Then
Rng.Text = Replace(Rng.Text, Chr(13), "")
Rng.Text = ""
Pn = ThisDocument.BuiltInDocumentProperties(wdPropertyPages)
If P <> Pn Then
P = P - 1
Else
Set Rng = ThisDocument.Range(Start:=ThisDocument.GoTo(wdGoToPage, wdGoToAbsolute, Pn - 1).Start, End:=ThisDocument.GoTo(wdGoToPage, wdGoToAbsolute, Pn + 1).Start)
If InStr(1, Rng.Text, Chr(12)) > 0 Then
Rng.Characters(InStr(1, Rng.Text, Chr(12))) = ""
Else
Set Rng = ThisDocument.Range(Start:=ThisDocument.GoTo(wdGoToPage, wdGoToAbsolute, P).Start)
Rng.Select: Selection.Delete
End If
Exit For
End If
End If
Next
End Sub

复制代码

aman1516 · 发表于 2022-5-18 11:32

附件在此：

删除空白页.rar (545.63 KB, 下载次数: 10)

		自动登录	找回密码
密码			免费注册

[求助] 删除空白页，熟悉WORD VBA的老师帮看下

评分