Используя VBA, распечатайте массив, созданный в Word, в Excel

Question

Я новичок в VBA и пытаюсь напечатать массив, который мне удалось создать (в основном, копируя из другого поста) в VBA сегодня.Я поместил перерыв в скрипт и проверил массив на странице местных жителей, чтобы увидеть, что массив захватывает то, что я хочу (и некоторые дополнительные данные, которые я отфильтрую).Я провел день, читая о печати массивов на переполнение стека и других сайтах, и я немного потерял.Моя цель - экспортировать массив в виде таблицы в Excel.

Скрипт ищет подчеркнутые предложения в документе из 400 страниц и помещает их в массив.Все, что действительно необходимо для печати, это подчеркнутые предложения, так что, возможно, массив был не лучшим подходом?Как я могу экспортировать массив «myWords» в новый документ Excel или в документ, который я обозначил?

Большое спасибо за вашу помощь!

Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
    Dim myWords()       As String
    Dim i               As Long
    Dim myDoc           As Document: Set myDoc = ActiveDocument ' Change as needed
    Dim aRange          As Range: Set aRange = myDoc.Content
    Dim sRanges         As StoryRanges: Set sRanges = myDoc.StoryRanges
    Dim ArrayCounter    As Long: ArrayCounter = 0 ' counter for items added to the array
    Dim Sentence        As Range
    Dim w               As Variant

    Application.ScreenUpdating = False
    ReDim myWords(aRange.Words.Count) ' set a array as large as the
                                      ' number of words in the doc

    For Each Sentence In ActiveDocument.StoryRanges
        For Each w In ActiveDocument.Sentences

            If w.Font.Underline <> wdUnderlineNone Then
                myWords(ArrayCounter) = w
                ArrayCounter = ArrayCounter + 1
            End If
        Next
    Next
Set myDoc = Nothing
    Set aRange = Nothing
    Set sRange = Nothing
    Application.ScreenUpdating = True
    Exit Sub

errhand:
    Application.ScreenUpdating = True
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
End Sub

Answer 1

В коде, представленном в вопросе, есть некоторые проблемы, которые я пытался исправить в соответствии с описанием проблемы.

1. Код объявляет количество переменных объекта, присваивая их в одной строкекак объявление, но эти объекты никогда не используются.Чтобы улучшить читаемость кода и сделать эти объекты «очевидными», я переместил экземпляры в новые строки.
2. Пример кода ниже затем заменяет эти объекты на ActiveDocument... объекты, использованные в исходном коде, гдеэти объекты предназначены для использования.Это делает код более читабельным и более эффективным.
3. Использование StoryRanges сомнительно в контексте кода.StoryRanges - это не то же самое, что Sentences.Предполагая, что использование StoryRanges было недоразумением или опечаткой, я изменил код для использования Sentences.Если подразумевается StoryRanges, код может проходить через них, но потребуются определенные структурные изменения.(StoryRanges позволяет коду получать доступ ко всем частям документа, таким как TextBoxes, Headers, Footers, Endnotes - вместо основной части документа.)
4. Нет смысла зацикливать предложения при определении размерамассив с количеством слов в документе.Это было изменено на количество предложений, что потребует меньше памяти.
5. В массив должен быть добавлен только текст, а не все предложение Range, поскольку Excel ничего не может сделать с Word.Range кроме принять его текст.Это потребует меньше памяти.
6. При условии, что не каждое предложение в документе подчеркнуто, нет необходимости поддерживать массив с пустыми членами, поэтому после цикла размер массива изменяется, чтобы он содержал только те, которые имеютбыл заселен.(ReDim Preserve myWords(ArrayCounter - 1)).Это позволит избежать записи «пустого» содержимого на лист Excel.

7. Код для записи в Excel находится в отдельной процедуре, что позволяет повторно использовать его для других массивов, которые, возможно, потребуется перенести в Excel.,Код был написан как поздняя привязка, что делает его независимым от ссылки на библиотеку Excel.Если требуется раннее связывание (со ссылкой), эти объявления закомментированы в строке.

8. Запись в Excel происходит только в том случае, если массив содержит элементы.Если ArrayCounter никогда не увеличивалось, вызов другой процедуры не выполняется.

9. Объектам Excel присваивается значение Nothing в конце этой процедуры.

Примечание. Код, размещенный в вопросе и используемый здесь, выбирает любое предложение, которое содержит подчеркивание.

Пример кода:

Sub addUnderlinedWordsToArray()
    On Error GoTo errhand:

    Dim myWords()       As String
    Dim i               As Long
    Dim myDoc           As Document
    Dim aRange          As Range
    Dim sRanges         As Sentences
    Dim ArrayCounter    As Long ' counter for items added to the array
    Dim Sentence        As Range
    Dim w               As Variant

    Application.ScreenUpdating = False
    Set myDoc = ActiveDocument ' Change as needed
    Set aRange = myDoc.content
    Set sRanges = myDoc.Sentences
    ArrayCounter = 0
    ReDim myWords(aRange.Sentences.Count - 1) ' set a array as large as the
                                      ' number of sentences in the doc

    For Each Sentence In sRanges
        If Sentence.Font.Underline <> wdUnderlineNone Then
            myWords(ArrayCounter) = Sentence.text
            ArrayCounter = ArrayCounter + 1
        End If
    Next

    If ArrayCounter > 0 Then
        ReDim Preserve myWords(ArrayCounter - 1)
        WriteToExcel myWords
    End If

    Set myDoc = Nothing
    Set aRange = Nothing
    Set sRanges = Nothing
    Application.ScreenUpdating = True
    Exit Sub

    errhand:
    Application.ScreenUpdating = True
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
End Sub

Sub WriteToExcel(a As Variant)
    Dim appExcel As Object   'Excel.Application
    Dim wb As Object         ' Excel.Workbook
    Dim r As Object          ' Excel.Range
    Dim i As Long

    Set appExcel = CreateObject("Excel.Application")
    appExcel.Visible = True
    appExcel.UserControl = True
    Set wb = appExcel.Workbooks.Add
    Set r = wb.Worksheets(1).Range("A1")
    r.Resize(UBound(myWords) + 1).Value = xlApp.Transpose(myWords)

    Set r = Nothing
    Set wb = Nothing
    Set appExcel = Nothing
End Sub

Answer 2

Я предпочитаю использовать Позднее связывание вместо добавления внешней ссылки в Excel.Это позволит коду работать должным образом независимо от того, какая версия Office установлена.

Sub addUnderlinedWordsToArray()
    On Error GoTo errhand:
    Dim myWords() As String
    Dim i As Long
    Dim myDoc As Document: Set myDoc = ActiveDocument    ' Change as needed
    Dim aRange As Range: Set aRange = myDoc.Content
    Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
    Dim ArrayCounter As Long: ArrayCounter = 0        ' counter for items added to the array
    Dim Sentence As Range
    Dim w As Variant

    Application.ScreenUpdating = False
    ReDim myWords(aRange.Words.Count)                 ' set a array as large as the
    ' number of words in the doc

    For Each Sentence In ActiveDocument.StoryRanges
        For Each w In ActiveDocument.Sentences
            If w.Font.Underline <> wdUnderlineNone Then
                myWords(ArrayCounter) = w
                ArrayCounter = ArrayCounter + 1
            End If
        Next
    Next

    ReDim Preserve myWords(ArrayCounter - 1)
    AddWordsToExcel myWords
    Set myDoc = Nothing
    Set aRange = Nothing
    Set sRange = Nothing
    Application.ScreenUpdating = True
    Exit Sub

errhand:
    Application.ScreenUpdating = True
    MsgBox "An unexpected error has occurred." _
           & vbCrLf & "Please note and report the following information." _
           & vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
           & vbCrLf & "Error Number: " & Err.Number _
           & vbCrLf & "Error Description: " & Err.Description _
           , vbCritical, "Error!"
End Sub

Sub AddWordsToExcel(myWords() As String)
    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")

    Dim wb As Object
    Set wb = xlApp.Workbooks.Add
    wb.Worksheets(1).Range("A1").Resize(UBound(myWords) + 1).Value = xlApp.Transpose(myWords)
    xlApp.Visible = True

End Sub

Answer 3

Общий ответ - использовать Range ("A1") = myWords(ArrayCounter). Вам нужно будет пройти по массиву, одновременно перемещаясь к следующей ячейке.

Вы также можете использовать Range ("A1:B3") = myWords.

Answer 4

Это проверено и работает нормально:

Option Explicit

Sub addUnderlinedWordsToArray()

    Dim myWords()       As String
    Dim i               As Long
    Dim myDoc           As Document: Set myDoc = ActiveDocument ' Change as needed
    Dim aRange          As Range: Set aRange = myDoc.Content
    Dim sRanges         As StoryRanges: Set sRanges = myDoc.StoryRanges
    Dim ArrayCounter    As Long: ArrayCounter = 0 ' counter for items added to the array
    Dim Sentence        As Range
    Dim w               As Variant
    Dim Ex0             As Excel.Application
    Dim Wb0             As Workbook

    Application.ScreenUpdating = False

    On Error GoTo errhand:
    For Each Sentence In ActiveDocument.StoryRanges
        For Each w In ActiveDocument.Sentences
            If w.Font.Underline <> wdUnderlineNone Then
                ReDim Preserve myWords(ArrayCounter)
                myWords(ArrayCounter) = w
                ArrayCounter = ArrayCounter + 1
            End If
        Next
    Next
    On Error GoTo 0

    Set myDoc = Nothing
    Set aRange = Nothing
    Set sRanges = Nothing


    Set Ex0 = New Excel.Application
    Set Wb0 = Ex0.workbooks.Add
    Ex0.Visible = True

    Wb0.Sheets(1).Range("A1").Resize(UBound(myWords) + 1, 1) = WorksheetFunction.Transpose(myWords)

    Application.ScreenUpdating = True

    Debug.Print UBound(myWords())

    Exit Sub

errhand:
    Application.ScreenUpdating = True
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
End Sub

Убедитесь, что Microsoft Excel 14.0 Object Library отмечен Tools/References