使用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

與向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 2

經過測試，可以正常工作：

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

確保在“ Tools/References勾選了Microsoft Excel 14.0 Object Library

Answer 3

問題中提供的代碼存在一些問題，我已嘗試根據問題描述進行糾正。

1. 該代碼聲明了許多對象變量，並在與聲明相同的行中分配了它們，但是這些對象從未使用過。 為了提高代碼的可讀性並使這些對象“顯而易見”，我將實例化到了新行。
2. 然后，下面的示例代碼將這些對象替換為原始代碼中要使用的ActiveDocument...對象。 這使代碼更易讀，更高效。
3. 在代碼的上下文中， StoryRanges的使用StoryRanges懷疑。 StoryRanges與Sentences 。 假設使用StoryRanges是一種誤解或錯別字，我已將代碼更改為使用Sentences 。 如果要使用StoryRanges ，則代碼可以在它們之間循環，但是需要進行某些結構更改。 （ StoryRanges使代碼可以訪問文檔的所有部分，例如TextBoxes，頁眉，頁腳，尾注-而不是文檔的主體。）
4. 在將數組調整為文檔中單詞的數量時，循環句子是沒有意義的。 這已更改為句子數，這將需要較少的內存。
5. 僅文本，而不是整個句子Range應該添加到數組，因為Excel不能對Word.Range進行任何操作， 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 4

通用答案是使用Range ("A1") = myWords(ArrayCounter)您需要在移動到下一個單元格的同時逐步通過數組。

您還可以使用Range ("A1:B3") = myWords 。