|
|
请利用制表符对齐:
参考
http://club.excelhome.net/viewth ... ngqingfu&page=2
16楼的方法
守版的VBA代码如下:
Sub 选项对齐之四个选项()
'基于选定内容的查找与替换
Dim myFind() As Variant, myReplace As String
Dim aArray As Variant, mySet As String, N As Integer, M As Integer
Dim myRange As Range, myBk As Bookmark
myFind = Array("A", "B", "C", "D", "Ａ", "Ｂ", "Ｃ", "Ｄ")
If Selection.Type = wdSelectionIP Then Exit Sub
Application.ScreenUpdating = False
Set myBk = ActiveDocument.Bookmarks.Add(Name:="Temp", Range:=Selection.Range)
With myBk.Range
'删除段落的首行缩进\左缩进和右缩进
With .ParagraphFormat
.CharacterUnitLeftIndent = 0 '如果不想要运行绿色的这几行代码,请在代码前面添加'
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.FirstLineIndent = CentimetersToPoints(0)
.TabStops.ClearAll '清除文档中所有制表位
.Space1 '单倍行距
End With
'设置字体字号
With .Font
.NameFarEast = "宋体"
.NameAscii = "Times New Roman"
.NameOther = "Times New Roman"
.Name = ""
.Size = 10.5
End With
'先删除文档中所有制表符
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.Execute findtext:="^t", replacewith:="", Replace:=wdReplaceAll
End With
'删除文档中所有非下划线的非英文后的一个或者多个全角\半角空格,包括段前空格\括号间空格
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([!a-zA-Z])[ " & ChrW(160) & "]{1,}"
.MatchWildcards = True
.Wrap = wdFindStop
.Font.Underline = False
.Execute replacewith:="\1", Replace:=wdReplaceAll
End With
'将连续5个中文字符以上段落的行距设置为20磅固定行距,可视具体情况更改之
With .Find
.ClearFormatting
.Format = True
.Replacement.ClearFormatting
.Replacement.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
.Replacement.ParagraphFormat.LineSpacing = 20
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[一-龥]{5,}"
.Execute replacewith:="", Replace:=wdReplaceAll
End With
'以下查找与替换设置制表位,使选项对齐,此替换维持原有选项样式
With .Find
.ClearFormatting
With .Replacement
.ClearFormatting
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(0.63)
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(4.03)
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(7.43)
.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(10.83)
End With
.Text = "[A-DＡ-Ｄ][.、．]"
.Replacement.Text = "^t^&"
.Wrap = wdFindStop
.Format = True
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
'针对AB和CD选项为两个段落的情况,重设制表位(删除4.03cm)
Set myRange = myBk.Range
NR1: With myRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "A[.、．][!^13]@B[.、．][!^13]@^13^tC[.、．]*D[.、．]*^13"
.MatchWildcards = True
Do While .Execute
With myRange
.ParagraphFormat.TabStops.ClearAll
.ParagraphFormat.TabStops.Add CentimetersToPoints(0.63)
.ParagraphFormat.TabStops.Add CentimetersToPoints(7.43)
.SetRange .End, myBk.Range.End
GoTo NR1
End With
Loop
End With
'规避查找中的过于复杂的表达式
Set myRange = myBk.Range
NR2: With myRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Ａ[.、．][!^13]@Ｂ[.、．][!^13]@^13^tＣ[.、．]*Ｄ[.、．]*^13"
.MatchWildcards = True
Do While .Execute
With myRange
.ParagraphFormat.TabStops.ClearAll
.ParagraphFormat.TabStops.Add CentimetersToPoints(0.63)
.ParagraphFormat.TabStops.Add CentimetersToPoints(7.43)
.SetRange .End, myBk.Range.End
GoTo NR2
End With
Loop
End With
'进行中英文括号替换,中间加入一个制表符
With .Find
.ClearFormatting
.Replacement.ClearFormatting
' .Replacement.ParagraphFormat.TabStops.ClearAll
' .Replacement.Font.Spacing = 12
.MatchWildcards = True
'替换为带有两个全角空格的西文括号
' .Execute findtext:="[\(（][\)）]", replacewith:="(" & vbTab & ")", Replace:=wdReplaceAll
.Execute findtext:="[\(（][\)）]", replacewith:="(^32^32^32) ", Replace:=wdReplaceAll
End With
With .ParagraphFormat
.LineUnitBefore = 0
.LineUnitAfter = 0
.SpaceBefore = 0
.SpaceAfter = 0
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
'更改或者统一文档选项样式
mySet = VBA.InputBox(Prompt:="请选择选项样式,1为'A.',2为'A．',3为 'A、',单击取消退出替换!", Title:="选项样式设置", Default:=1)
Select Case mySet
Case ""
myBk.Delete
Exit Sub
Case 1
myReplace = ". " '"[A-D]."还一个半角空格,防止拼写检查错误
N = 64
Case 2
myReplace = "．" '"[A-D]．"
N = 64 '如果要替换为ＡＢＣＤ的样式，则N=-23616
Case 3
myReplace = "、" '"[A-D]、"
N = 64
Case Else
myReplace = aArray
If aArray = "[A-D]．" Then
N = -23616
Else
N = 64
End If
End Select
For Each aArray In myFind
M = M + 1
If M = 5 Then M = 1
' Debug.Print VBA.Chr(M + N) & myReplace
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Execute findtext:=aArray & "[.、．]", replacewith:=VBA.Chr(M + N) & myReplace, Replace:=wdReplaceAll
End With
Next
myBk.Delete
End With
Application.ScreenUpdating = True
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-3-27 17:54
楼主
