VBA Word用一行扩展范围 [英] VBA Word Expand Range with one line

问题描述

首先，这是我第一次使用VBA代码创建宏.我在互联网上发现了一些零碎的内容，试图创建以下内容.我根本不是开发人员，我只有一些基础知识.因此，如果编码不好，我深表歉意.

First of all this is the first time I am creating a macro using VBA code. With some bits and pieces i found on the internet I tried to create the following. I am not a developer at all, I just have some basic knowledge from school. So my apologies if this is poor coding.

我正在用单词创建一个宏，该宏突出显示从段落标题到下一个具有相同样式的标题的文本.这是根据我从Excel导入的标题列表完成的.您可以在下面找到我创建的代码.输入很少的结果是完美的，所以这是一件好事！不过执行速度非常慢(3到4小时)，这可能与我使用的许多选择有关.(我只读到了，这通常是导致慢​​速宏的原因)

I am creating a macro in word which highlights text from a paragraph heading until the next heading with the same style. This is done based on a list of headings I import from Excel. You can find the code I have created below. The result with few input is perfect, so that's a good thing! The execution is very slow though (3 to 4h), which is probably related to the many selects I use. (I read only this is very often the cause of slow macros)

我尝试一次使用"Range.Expand Unit:= wdLine"将我的范围扩大到一行，但每次都会给我错误.因此，我现在使用moveDown选择方法来解决问题.有人知道我可以在此处使用范围来加快过程的方法吗?

I tried to expand my Range with one line at the time using " Range.Expand Unit:=wdLine " but it's giving me errors every time. Therefore I use the moveDown selection method now which is doing the trick. Does anyone know a way I could use ranges here to speed up the process?

非常感谢.

    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'书签来突出显示与不同标题级别相关的范围的简便方法:

The following code shows a much easier way of highlighting the ranges associated with different heading levels, using Word's built-in '\HeadingLevel' bookmark:

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个标题级别，最终以给定的高亮显示取决于在给定的较高级别标题(较低数量)中嵌套了多少其他较低级别的标题(较高数量)

Of course, as the above code loops through all 9 heading levels, what ends up with a given highlight depends on how many other lower-level headings (higher numbers) are nested within a given higher-level heading (lower numbers).

这篇关于VBA Word用一行扩展范围的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！