ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 10956|回复: 3

VBA删除段落首尾空格和空白段落

[复制链接]

TA的精华主题

TA的得分主题

发表于 2010-2-7 22:11 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
以下下程序在Word2003下运行通过,对选中段落有效。
可以把删除段首尾空格和空白行结合起来做个一键删空,效果不错。
全角和tab空格也能有效删除。
采用Word的查找替换功能,^p为段落标记,^w为空白标记。
对于段首空格,需要先插入一个辅助回车符。

Sub DelSpacesAheadPara()
'删除段首空格


   
If Len(Selection.Text) < 2 Then Exit Sub
   
   
On Error Resume Next
    Application.ScreenUpdating
= False
   
   
Dim rngSel As Range
   
Set rngSel =
Selection.Range
   
    rngSel.InsertBefore Text:
=vbCrLf    '插入一个辅助回车符

    Call FindReplaceChar("^p^w", "^p", wdFindStop, bByte:=False)
   
If Len(rngSel.Paragraphs(1).Range.Text) < 2 Then
_
            rngSel.Paragraphs(
1).Range.Delete    '删除辅助回车符

    rngSel.Select
   
    Application.ScreenUpdating
= True

   
Set rngSel = Nothing

End Sub

Sub DelSpacesBehindPara()
'删除段尾空格


   
If Len(Selection.Text) < 2 Then Exit Sub
   
On Error Resume Next
   
    Application.ScreenUpdating
= False
   
Call FindReplaceChar("^w^p", "^p", wdFindStop, bByte:=False)
    Application.ScreenUpdating
= True


End Sub

Sub DelSpacesBoth()
'删除段尾空格


   
If Len(Selection.Text) < 2 Then Exit Sub
   
On Error Resume Next
   
   
Dim rngSel As Range
   
Set rngSel =
Selection.Range
    Application.ScreenUpdating
= False


   
Call FindReplaceChar("^w^p", "^p", wdFindStop, bByte:=False)
    rngSel.InsertBefore Text:
=
vbCrLf
   
Call FindReplaceChar("^p^w", "^p", wdFindStop, bByte:=False
)
   
If Len(rngSel.Paragraphs(1).Range.Text) < 2 Then
_
            rngSel.Paragraphs(
1
).Range.Delete
    rngSel.Select
   
    Application.ScreenUpdating
= True

   
Set rngSel = Nothing

End Sub

Sub DelBlankPara()
'删空行和无内容的行


   
If Len(Selection.Text) < 2 Then Exit Sub
  
   
On Error Resume Next
    Application.ScreenUpdating
= False
   
   
Dim rngSel As Range
   
Dim Para As
Paragraph
   
Set rngSel =
Selection.Range
   
   
For Each Para In
rngSel.Paragraphs
        
With
Para
            
If Len(Trim(.Range.Text)) = 1 Then

                .Range.Delete
            
End If
        
End With
        
If rngSel.Paragraphs.Count = 1 Then Exit For   '避免死循环
    Next Para
    rngSel.Select
   
    Application.ScreenUpdating
= True

   
Set rngSel = Nothing
   
Set Para = Nothing

End Sub

Private Sub FindReplaceChar(ByVal strFind As String, ByVal strReplace As String, _
   
ByVal FindWrap As Integer, Optional ByVal bWild As Boolean = False
, _
   
Optional ByVal bByte As Boolean = True, Optional ByVal nReplace As Integer =
wdReplaceAll)
'执行查找替换操作


    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
   
With Selection.Find
        .Text
=
strFind
        .Replacement.Text
=
strReplace
        .Forward
= True

        .Wrap
= FindWrap 'wdFindStop:停止,替换选定部分,若没选中则替换至文档末尾
        .Format = False
        .MatchCase
= False
        .MatchWholeWord
= False
        .MatchByte
= bByte
        .CorrectHangulEndings
= False

        .MatchWildcards
= bWild
        .MatchSoundsLike
= False

        .MatchAllWordForms
= False
   
End With
    Selection.Find.Execute
Replace:=nReplace
    ActiveDocument.Activate
   
End Sub


[ 本帖最后由 tsgang 于 2010-2-7 22:20 编辑 ]

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2010-2-7 22:39 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2010-2-8 11:16 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-12-17 16:56 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
Sub DelSpacesBehindPara()
'删除段尾空格

    If Len(Selection.Text) < 2 Then Exit Sub
     On Error Resume Next
     
    Application.ScreenUpdating = False
     Call FindReplaceChar("^w^p", "^p", wdFindStop, bByte:=False)
     Application.ScreenUpdating = True

End Sub
报告:Call FindReplaceChar,显示“子过程或函数未定义”
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 22:04 , Processed in 0.043519 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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