vba 对 word 的常用操作

时间：2024-02-19 17:36:11

　一、选中某些字或段落
　　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

 

  1. 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/52141385

     

     

    Sub 选取所有表格()

\'
\' 选取表格 宏
\'
     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 Sub




    Sub 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

     

相关文章