arrays - 使用 VBA，将 Word 中的数组打印到 Excel

Question

我是 VBA 新手，我正在尝试打印一个我今天能够在 VBA 中制作的数组(基本上是从另一篇文章中复制的)。我在脚本中放置了一个中断并检查了本地页面中的数组，以查看该数组是否捕获了我想要的内容(以及一些我将过滤掉的额外数据)。我花了一天时间阅读有关在堆栈溢出和其他站点上打印数组的内容，结果我有点迷失了。我的目标是将数组导出为 Excel 中的表格。

该脚本在 400 页 word 文档中查找带下划线的句子并将它们放入数组中。打印真正需要的是带下划线的句子，所以也许数组不是最好的方法？如何将数组“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

我更喜欢使用后期绑定(bind)而不是添加对 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