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