VBA Word расширяет диапазон одной строкой

Question

Прежде всего, это первый раз, когда я создаю макрос с использованием кода VBA. С некоторыми фрагментами, которые я нашел в inte rnet, я попытался создать следующее. Я вообще не разработчик, у меня просто базовые знания из школы. Поэтому я извиняюсь за плохое кодирование.

Я создаю макрос в слове, который выделяет текст от заголовка абзаца до следующего заголовка с тем же стилем. Это делается на основе списка заголовков, которые я импортирую из 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

Answer 1

В следующем коде показан гораздо более простой способ выделения диапазонов, связанных с различными уровнями заголовка, с помощью встроенной в 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 уровней заголовков то, что заканчивается данным выделением, зависит от того, сколько других заголовков более низкого уровня (более высокие числа) вложены в данный заголовок более высокого уровня (более низкие числа).

Answer 2

Во-первых, это поможет вам ознакомиться с помощью справки. Поместите курсор в ключевое слово, с которым вам нужна помощь, и нажмите F1. Если бы вы сделали это для метода Expand, вы бы приземлились здесь . Вы найдете действительные параметры для Единицы измерения .

Во-вторых, стили абзацев применяются к абзацам , а не к строкам. Поэтому вам необходимо проверить стиль каждого абзаца и расширить диапазон на один абзац за раз. Это позволит вам не выбирать ничего.