excel - VBA Word 用一行扩展范围
问题描述
首先,这是我第一次使用 VBA 代码创建宏。我在互联网上找到了一些零碎的东西,我尝试创建以下内容。我根本不是开发人员,我只是从学校获得了一些基本知识。因此,如果这是糟糕的编码,我深表歉意。
我正在用 word 创建一个宏,它突出显示段落标题中的文本,直到具有相同样式的下一个标题。这是根据我从 Excel 导入的标题列表完成的。您可以在下面找到我创建的代码。输入很少的结果是完美的,所以这是一件好事!执行速度很慢(3 到 4 小时),这可能与我使用的许多选择有关。(我只读这通常是宏慢的原因)
我当时尝试使用“ Range.Expand Unit:=wdLine ”用一行来扩展我的范围,但每次都给我错误。因此,我现在使用 moveDown 选择方法来解决问题。有谁知道我可以在这里使用范围来加快进程的方法?
提前谢谢了。
Sub Highlight_WordN()
Dim par As Paragraph
Dim par2 As Paragraph
Dim doc As Document
Dim oRng As Range
Dim Sty As Style
Dim intCurrentLine As Integer
Dim strFindArray() As String
Dim strIn As String
Dim strWorkBookName As String
Dim strNumberCells As String
Dim MessageFound As String
Dim MessageNotFound As String
Dim Flag As Boolean
Dim IsHeading As Boolean
Dim IsNothing As Boolean
'*****Set parameters for performance*****
Word.Application.ScreenUpdating = False
Word.Application.Options.CheckGrammarAsYouType = False
Word.Application.Options.CheckGrammarWithSpelling = False
Word.Application.Options.CheckSpellingAsYouType = False
Word.Application.Options.AnimateScreenMovements = False
Word.Application.Options.BackgroundSave = False
Word.Application.Options.CheckHangulEndings = False
Word.Application.Options.DisableFeaturesbyDefault = True
'*****Load data from excel*****
'List of headers to delete
Dim xlApp As Object
Dim xlBook As Object
strWorkBookName = "C:\Users\driesenn\OneDrive\OMAR\UPDATE\ToDelete.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkBookName)
xlApp.Visible = False
ArrayLen = 0
ArrayLen = xlApp.ActiveSheet.Range("B1")
strNumberCells = "A1:A" & ArrayLen
strArray = xlApp.Transpose(xlApp.ActiveSheet.Range(strNumberCells))
ArrayLen = 0
ArrayLen = UBound(strArray) - LBound(strArray) + 1
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
'*****Start evaluation process for headers*****
ArrayLen = UBound(strArray) - LBound(strArray) + 1
'Loop over all headers in the array
For i = 1 To ArrayLen
strFind = strArray(i)
'Evaluate every paragraph heading
For Each par In ActiveDocument.Paragraphs
If par.Style Like "Heading*" Then
Set Sty = par.Style
'Search for the header number in the heading
If InStr(par.Range.Text, strFind) = 1 Then
Set oRng = par.Range
oRng.Select
intCurrentLine = oRng.Information(wdFirstCharacterLineNumber)
Set oRng = Selection.Next(Unit:=wdLine, Count:=1)
'If the next line is not a header --> go on
IsHeading = False
If oRng.Style Like "Heading*" Then
IsHeading = True
End If
'Keep looping until the next heading of this type is found
Do While oRng.Style > Sty Or IsHeading = False
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Set oRng = Selection.Next(Unit:=wdLine, Count:=1)
If oRng Is Nothing Then
Exit Do
End If
'If the next line is not a header --> go on
IsHeading = False
If oRng.Style Like "Heading*" Then
IsHeading = True
End If
Loop
Selection.Start = par.Range.Start
'If we are not at the end of the document selection ends with last line of current range.
If oRng Is Nothing Then
Else
Selection.End = oRng.Start
End If
'Set highlight
Selection.Range.HighlightColorIndex = wdYellow
End If
End If
Next
Next
End Sub
解决方案
以下代码显示了一种更简单的方法来突出显示与不同标题级别相关的范围,使用 Word 的内置 '\HeadingLevel' 书签:
Sub Demo()
Dim h As Long, c As Long, Rng As Range
For h = 1 To 9
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Style = "Heading " & h
.Replacement.Text = ""
.Format = True
.Forward = True
.Execute
End With
Do While .Find.Found
Set Rng = .Paragraphs(1).Range
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
Select Case h
Case 1 To 4: c = h + 1
Case 5: c = h + 2
Case 6 To 8: c = h + 4
Case 9: c = h + 5
Case Else: c = 0
End Select
Rng.HighlightColorIndex = c
.Collapse wdCollapseEnd
If .Information(wdWithInTable) = True Then
If .End = .Cells(1).Range.End - 1 Then
.End = .Cells(1).Range.End
.Collapse wdCollapseEnd
If .Information(wdAtEndOfRowMarker) = True Then .End = .End + 1
End If
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
End Sub
当然,当上面的代码循环遍历所有 9 个标题级别时,以给定突出显示结束的内容取决于有多少其他较低级别的标题(较高的数字)嵌套在给定的较高级别的标题(较低的数字)中。
推荐阅读
- mongodb - 是否可以将 mongoDB 地理空间索引与网格 FS 一起使用
- python - 在 Jupyter 中导入 Axes3D 时出现键错误
- java - 如何通过方法将项目添加到HashMap
- python - 如何在 conda 中安装项目所需的所有依赖项?
- python - If value in dataframe row = list (not in order), change another row value to 'ONLINE'
- c# - do i have to install database on client's system?
- node.js - Ngrok > Nginx > 本地主机端口
- python-3.x - Iterating through list of multiple dictionary to show key only once and value in columns
- node.js - 套接字(socket.io)是否基于上下文?
- javascript - 如何将svg放在svg之上?