|
|
楼主 |
发表于 2019-11-14 12:07
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
通过查找老师们的代码，写出了自己的代码。请大侠们指正。
1、由于对代码的理解不到位，可能有些代码是多余的，请帮助精简优化。
2、还有2个问题没有解决，请高手指点。 一是：我在EXCEL表格中设定的“（1）”，本想是将文档中带括号的进行处理，但实际将文档中的“1.”、“2.”进行了处理。不知道代码的什么地方出现了问题。
二是EXCEL文件在后台打开，似乎没有完全关闭，每运行一次宏，就会打开一个EXCEL进程，导致必须将EXCEL文件设定为共享模式，才能进行正常的操作。
Sub A123()
Dim Myname, MySize, MyColor, MyAlignment, MyLineUnitBefore, MyLineUnitAfter ', MyCharacterUnitFirstLineIndent
Application.ScreenUpdating = False
Dim mytable, myFirstRow As Range
Dim strHuzhu As String
Dim strZhuzhi As String
Dim AppExcel As Excel.Application, Wk As Excel.Workbook, Wksh As Excel.Worksheet
'以下操作打开一个Excel文件***
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False '单选择
.Filters.Clear '清除文件过滤器
.Filters.Add "Excel Files", "*.xls;*.xlw;*.xlsx"
.Filters.Add "All Files", "*.*" '设置两个文件过滤器
If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
myfilepath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Set AppExcel = CreateObject("Excel.Application")
Set Wk = AppExcel.Workbooks.Open(myfilepath)
Set Wksh = Wk.Sheets(1)
'以下操作删除WORD文档的空行、空白区域
Dim objFind As Find
Set objFind = ActiveDocument.Content.Find
objFind.Execute Wrap:=wdFindContinue, MatchWildcards:=True, findtext:="^13{2,}", replacewith:="^p", Replace:=wdReplaceAll '删除空行
objFind.Execute Wrap:=wdFindContinue, MatchWildcards:=False, findtext:="^w", replacewith:="", Replace:=wdReplaceAll
'^w(必须是小写)替换非空白区域，可将全角空格、半角空格、制表符空格全部删除，但需要在非通配符情况下使用，所以需要设置 MatchWildcards:=False
For i = 2 To 10
'以下读EXCEL文件中设定的取格式*****
Mytext = Wksh.Range("A" & i) '从EXCEL文件中取得搜索关键字
If Len(Mytext) = 0 Then GoTo AAA '如果搜索关键字是空的，则跳出循环
TT = ""
Myname = Wksh.Range("H" & i).Text
MyBold = IIf(Wksh.Range("K" & i).Text = "是", True, False)
MySize = Wksh.Range("I" & i).Text
Select Case Wksh.Range("J" & i).Text
Case Is = "黑"
MyColor = wdColorBlack
Case Is = "红"
MyColor = wdColorRed
Case Is = "蓝"
MyColor = wdColorBlue
End Select
MyLineUnitBefore = Wksh.Range("L" & i).Text '段前行数
MyLineUnitAfter = Wksh.Range("M" & i).Text '段后行数
MyCharacterUnitFirstLineIndent = Wksh.Range("G" & i).Text '行首空格
Select Case Wksh.Range("F" & i).Text
Case Is = "左对齐"
MyAlignment = wdAlignParagraphLeft
Case Is = "居中"
MyAlignment = wdAlignParagraphCenter
Case Is = "右对齐"
MyAlignment = wdAlignParagraphRight
End Select
'以下根据EXCEL文件中设定，调整WORD文档的格式**
If Wksh.Range("A" & i).Text = "正文" Then
Selection.WholeStory
With Selection ' 全文总基调
With .ParagraphFormat
If MyLineUnitBefore <> "" Then .LineUnitBefore = MyLineUnitBefore '返回或设置指定段落的段后间距（以网格线为单位）。
If MyLineUnitAfter <> "" Then .LineUnitAfter = MyLineUnitAfter '返回或设置指定段落的段前间距（以网格线为单位）。
If MyCharacterUnitFirstLineIndent <> "" Then .CharacterUnitFirstLineIndent = MyCharacterUnitFirstLineIndent '行首缩进
If MyAlignment <> "" Then .Alignment = MyAlignment '对齐方式
.OutlineLevel = wdOutlineLevelBodyText
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0 '段前0行×5=0 ，但似乎不起作用
.SpaceAfter = 0 '段后0行×5=0，但似乎不起作用
.FirstLineIndent = CentimetersToPoints(0.35)
'.SpaceBeforeAuto = False '自动设置段前空行，单位：镑
'.SpaceAfterAuto = False '自动设置段后空行，单位：镑
.LineSpacingRule = wdLineSpaceSingle
'段落行距:wdLineSpace1pt5、wdLineSpaceAtLeast、wdLineSpaceDouble、wdLineSpaceExactly、wdLineSpaceMultiple、wdLineSpaceSingle
.WidowControl = False '
.KeepWithNext = False '与下段同页，本项和下一项去掉勾选，可标题行首的黑点不显示。
.KeepTogether = False '段中不分页
.PageBreakBefore = False '如果该属性值为 True，则在指定段落前插入分页符。
.NoLineNumber = False '如果该属性值为 True，则取消指定段的行号。
.Hyphenation = True '
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0 。
.MirrorIndents = False
.TextboxTightWrap = wdTightNone '
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False .FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
With .Font
If Myname <> "" Then .Name = Myname
If MyBold <> True Or False Then .Bold = MyBold
If MySize <> "" Then .Size = MySize
If MyColor <> "" Then .Color = MyColor
End With
End With
Else
If InStr("章节条", Mytext) <> 0 Then '如果搜索关键字中包含了“章/节/条”之一
TT = "第[一二三四五六七八九十百]@" & Mytext
ElseIf InStr(Mytext, "一") Then
TT = Replace(Mytext, "一", "[一二三四五六七八九十百]{1,5}")
Else
TT = Replace(Mytext, "1", "[1234567890]{1,3}")
End If
If Wksh.Range("E" & i).Text = "是" Then
TT = "^13" & TT '处理是否要求从段落开头匹配
Else
TT = "[^13。；，”！：]{1}" & TT
End If
If Wksh.Range("D" & i).Text = "是" Then TT = TT & "*[。；]" '处理是否要求拓展
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = TT '"第[一二三四五六七八九十百]@" & Wksh.Range("A" & i).Text
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveStart
If Wksh.Range("N" & i).Text = "是" Then .InsertAfter Text:=" " '在找到的串后面加上两个空格
If Wksh.Range("C" & i).Text = "是" Then '如果是整个段落字体调整
With .Paragraphs(1).Range.ParagraphFormat ' .Paragraphs(1)应当理解为所找到区域的第一段
If MyLineUnitBefore <> "" Then .LineUnitBefore = MyLineUnitBefore '返回或设置指定段落的段后间距（以网格线为单位）。
If MyLineUnitAfter <> "" Then .LineUnitAfter = MyLineUnitAfter '返回或设置指定段落的段前间距（以网格线为单位）。
If MyCharacterUnitFirstLineIndent <> "" Then .CharacterUnitFirstLineIndent = MyCharacterUnitFirstLineIndent '行首缩进
If MyAlignment <> "" Then .Alignment = MyAlignment '对齐方式
End With
With .Paragraphs(1).Range.Font
If Myname <> "" Then .Name = Myname
If MyBold <> True Or False Then .Bold = MyBold
If MySize <> "" Then .Size = MySize
If MyColor <> "" Then .Color = MyColor
End With
Else '只对查找部分调整字体
With .Font
If Myname <> "" Then .Name = Myname
If MyBold <> "" Then .Bold = MyBold
If MySize <> "" Then .Size = MySize
If MyColor <> "" Then .Color = MyColor
End With
End If
.Start = .End
End With
Loop
End With
.HomeKey Unit:=wdStory
End With
End If
AAA:
Next
'操作退出excel文件
AppExcel.Quit
Set Wksh = Nothing
Set Wk = Nothing
Set AppExcel = Nothing
Application.ScreenUpdating = True
End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-11-8 14:54
