vba 对 word 的常用操作
一、选中某些字或段落
ActiveDocument.Words(3).Select
ActiveDocument.Paragraphs(3).Range.Select
二、选中红色文字所在的段落
Dim myRange As Range
Set myRange = ActiveDocument.Content
'定义myRange为主文档文章
With myRange.Find
'在里面主文档里面查找东西
.Format = True
.Font.Color = wdColorBlue '字体为蓝色
If .Execute = True Then myRange.Paragraphs(1).Range.Select
'运行指定的查找操作,如果查找成功,则选取
End With
1、打开导航菜单
If Not aWord.ActiveWindow.DocumentMap Then
aWord.ActiveWindow.DocumentMap = True
End If
2、
If aWord.Selection.Find.Execute(ftxt) Then ‘查找标题定位（查找内容包括chr(13)）
' myPar.Range.Select
Set rng = aWord.Selection.Bookmarks("\headinglevel").Range ’RNG选择标题及内容
' For Each tb In rng.Tables
' tb.Delete
' Next tb
'删除原有内容（rng设定除标题外的所有内容）
rng.SetRange Start:=rng.Paragraphs(1).Range.End, End:=rng.Paragraphs(rng.Paragraphs.Count).Range.End
rng.Select
rng.Delete
' For n = rng.Paragraphs.Count To 2 Step -1
'
' rng.Paragraphs(n).Range.Delete
' Next n
aWord.Selection.MoveLeft
aWord.Selection.MoveUntil cset:=Chr(13) ‘移动光标到行尾回车处
aWord.Selection.TypeParagraph '增加一行
aWord.Selection.Style = aWord.ActiveDocument.Styles("正文")
aWord.Activate
aWord.Selection.Paste
Call JustEmptyClipboard ’清空剪贴板（过程见后）
End If
’清空剪贴板
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Public Sub JustEmptyClipboard()
OpenClipboard (0)
EmptyClipboard
CloseClipboard
End Sub
'
获得指定表格的某个单元格内容
Application.ActiveDocument.Tables(1).Cell(1, 1).Range.Text
'
获取指定表格所在页
Application.ActiveDocument.Tables(2).Select
Selection.Information(wdActiveEndPageNumber)
'
获取当前页面的开始字符数
Application.ActiveDocument.Bookmarks("\page").Start
'
获取当前页面的结束字符数
Application.ActiveDocument.Bookmarks("\page").End
'
获取当前页面中的图片数
Application.ActiveDocument.Bookmarks("\page").Range.InlineShapes.Count
Sub a格式化表格()
Dim T As Table
Application.ScreenUpdating = False
For Each T In ActiveDocument.Tables
T.Select
Call 加粗框线
Selection.Font.NameFarEast = "宋体" ' 改变表格字体为“黑体”
Selection.Font.Size = 9 ' 改变表格字号为9磅 小五
T.AutoFitBehavior (wdAutoFitWindow)
With T
.Cell(1, 1).Select
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
With Selection
.SelectRow '选中当前行
If .Cells.Count = 1 Then
.Shading.BackgroundPatternColor = wdColorWhite
Call 首行是表名的表格线处理
T.Cell(2, 1).Select
.SelectRow
End If
' Selection.Rows.HeadingFormat = wdToggle '自动标题行重复
' .Range.Font.Bold = True '表头加粗黑体
.Shading.ForegroundPatternColor = wdColorAutomatic '首行自动颜色
.Shading.BackgroundPatternColor = wdColorGray10 '首行底纹填充
End With
Next
Application.ScreenUpdating = True
MsgBox ("调整结束！")
End Sub
Sub 加粗框线()
With Selection.Cells
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderHorizontal)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth075pt
.Color = wdColorAutomatic
End With
.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
.Borders.Shadow = False
End With
End Sub
Sub 首行是表名的表格线处理()
'
' 宏1 宏
'
'
Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderRight).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
Selection.Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
With Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
End Sub
用过的调整程序，记录备用！
Sub 调整首行是表名的居中()
Dim T As Table
Application.ScreenUpdating = False
For Each T In ActiveDocument.Tables
T.Select
T.Cell(1, 1).Select
With Selection
.SelectRow '选中当前行
If .Cells.Count = 1 Then
.Font.Bold = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.SelectRow
End If
End With
Next
Application.ScreenUpdating = True
MsgBox ("调整结束！")
End Sub
Sub 调整表格内首行表头居中加黑()
Dim T As Table
Application.ScreenUpdating = False
For Each T In ActiveDocument.Tables
T.Select
T.Cell(1, 1).Select
With Selection
.SelectRow '选中当前行
If .Cells.Count = 1 Then
T.Cell(2, 1).Select
.SelectRow
End If
.Font.Bold = wdToggle
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next
Application.ScreenUpdating = True
MsgBox ("调整结束！")
End Sub
Sub Test()
Dim myRange As Range
Dim num As String, title As String
Selection.HomeKey wdStory '光标加到文首
'Set ps = Selection.Bookmarks("\headinglevel").Range.Paragraphs
Set ps = ActiveDocument.Bookmarks("\headinglevel").Range.Paragraphs
' Set Rng = Selection.Bookmarks("headinglevel").Range
For Each p In ps
Set myRange = p.Range
If Len(myRange.ListFormat.ListString) > 0 Then num = myRange.ListFormat.ListString
title = myRange.Text
Debug.Print "编号：" & num & vbCrLf & "标题内容：" & title
If num = "1.1.1.1" Then
myRange.Delete
End If
Next p
'Set myRange = Selection.Bookmarks("\headinglevel").Range.Paragraphs(1).Range
'MsgBox "编号：" & myRange.ListFormat.ListString & vbCrLf & "标题内容：" & myRange.Text
End Sub
Sub 按章节提取保留文档()
'自测题章节保留在文档中，与其同级的章节剪切成一个新文档，且用章节标题命名
Dim Par As Paragraph, ParNum As Integer
Dim NewDoc As Document, myDoc As Document
Dim FileName As String, Rng As Range, TitPar As Paragraph
Dim i As Integer
i = 0
Set myDoc = ActiveDocument
Selection.HomeKey wdStory '光标加到文首
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
Do While .Execute(FindText:="总体情况") '自测题的标题特征为段末 “（附参考答案）”
Set Par = Selection.Paragraphs(1) '获得自测题的标题
ParNum = Par.OutlineLevel '获得标题的大纲级别
'自测题大纲级别不会为1，不考虑为1级时的情况
Selection.GoTo wdGoToHeading, wdGoToPrevious, 1 '去往上一个标题
Do Until Selection.Paragraphs(1).OutlineLevel < ParNum '遇到上级大纲时停止循环
Set TitPar = Selection.Paragraphs(1)
If TitPar.OutlineLevel = ParNum Then '如果titpar的大纲级别与自测题标题的相等，则进行操作
FileName = Mid(TitPar.Range, 2, Len(TitPar.Range) - 2) '获得标题文本，用作文件名。一定要去掉段落标志，否则保存将出现保存许可权的错误
Set Rng = Selection.Bookmarks("headinglevel").Range '获得该标题下的所有内容
Rng.Cut '剪切内容
Set NewDoc = Documents.Add '新建一个文档
NewDoc.Content.Paste '粘贴复制的内容,源格式粘贴
NewDoc.SaveAs "F:userdataDesktop" & FileName & ".docx" '保存文档
NewDoc.Close
myDoc.Activate '激活原文档，防止意外处理其他文档
i = i + 1
End If
Selection.GoTo wdGoToHeading, wdGoToPrevious, 1 '再走到上一个标题
Loop
'定位到自测标题段落的下一个段落，防止重复查找
Par.Range.Select
Selection.MoveDown wdParagraph, 2
Loop
End With
Set NewDoc = Nothing
Set myDoc = Nothing
Set Rng = Nothing
MsgBox "共生成新文档数量为" & i
MsgBox "处理完成"
End Sub
-
Sub 按章节提取保留文档()
'自测题章节保留在文档中，与其同级的章节剪切成一个新文档，且用章节标题命名
Dim Par As Paragraph, ParNum As Integer
Dim NewDoc As Document, myDoc As Document
Dim FileName As String, Rng As Range, TitPar As Paragraph
Dim i As Integer
i = 0
Set myDoc = ActiveDocument
Selection.HomeKey wdStory '光标加到文首
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
Do While .Execute(FindText:="（附参考答案）") '自测题的标题特征为段末 “（附参考答案）”
Set Par = Selection.Paragraphs(1) '获得自测题的标题
ParNum = Par.OutlineLevel '获得标题的大纲级别
'自测题大纲级别不会为1，不考虑为1级时的情况
Selection.GoTo wdGoToHeading, wdGoToPrevious, 1 '去往上一个标题
Do Until Selection.Paragraphs(1).OutlineLevel < ParNum '遇到上级大纲时停止循环
Set TitPar = Selection.Paragraphs(1)
If TitPar.OutlineLevel = ParNum Then '如果titpar的大纲级别与自测题标题的相等，则进行操作
FileName = Mid(TitPar.Range, 2, Len(TitPar.Range) - 2) '获得标题文本，用作文件名。一定要去掉段落标志，否则保存将出现保存许可权的错误
Set Rng = Selection.Bookmarks("headinglevel").Range '获得该标题下的所有内容
Rng.Cut '剪切内容
Set NewDoc = Documents.Add '新建一个文档
NewDoc.Content.Paste '粘贴复制的内容,源格式粘贴
NewDoc.SaveAs "F:userdataDesktop" & FileName & ".docx" '保存文档
NewDoc.Close
myDoc.Activate '激活原文档，防止意外处理其他文档
i = i + 1
End If
Selection.GoTo wdGoToHeading, wdGoToPrevious, 1 '再走到上一个标题
Loop
'定位到自测标题段落的下一个段落，防止重复查找
Par.Range.Select
Selection.MoveDown wdParagraph, 2
Loop
End With
Set NewDoc = Nothing
Set myDoc = Nothing
Set Rng = Nothing
MsgBox "共生成新文档数量为" & i
MsgBox "处理完成"
End Sub‘单元格合并
Sub ctreatetable()
Dim Tbl As Table
Set Tbl = ActiveDocument.Tables.Add(ActiveDocument.Range(0, 0), numrows:=18, numcolumns:=4) '在文档开头插入一个两行四列的表格
With Tbl
With .Borders '设置表格边框线为单实线
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With
For i = 1 To 5
ActiveDocument.Range(.Cell(i, 2).Range.Start, .Cell(i, 4).Range.End).Cells.Merge '合并第i行2~4个格
Next i
'合并第7~16行第1列
.Cell(Row:=7, Column:=1).Select
Selection.MoveDown Unit:=wdLine, Count:=8, Extend:=wdExtend
Selection.Cells.Merge
For i = 17 To 18
ActiveDocument.Range(.Cell(i, 2).Range.Start, .Cell(i, 4).Range.End).Cells.Merge '合并第i行2~4个格
Next i
End With
End Sub
————————————————
版权声明：本文为CSDN博主「chenqiai0」的原创文章，遵循CC 4.0 BY-SA版权协议，转载请附上原文出处链接及本声明。
原文链接：https://blog.csdn.net/chenqiai0/article/details/52141385Sub 选取所有表格() ' ' 选取表格 宏 ' Dim T As Table Application.ScreenUpdating = False ActiveDocument.DeleteAllEditableRanges wdEditorEveryone For Each T In ActiveDocument.Tables T.Range.Editors.Add wdEditorEveryone Next ActiveDocument.SelectAllEditableRanges wdEditorEveryone ActiveDocument.DeleteAllEditableRanges wdEditorEveryone Application.ScreenUpdating = True End SubSub word定位()
Dim r1, r2, rng As Range
Set rng = ActiveDocument.Content
With rng.Find
.Text = "总体概述" & Chr(13)
.Forward = True
End With
If rng.Find.Execute Then
r1 = rng.End
End If
Set rng = ActiveDocument.Content
With rng.Find
.Text = "综合查询" & Chr(13)
.Forward = True
End With
If rng.Find.Execute Then
r2 = rng.Start
End If
ActiveDocument.Range(r1, r2).Select
End Sub
