使用VBA，将Word中创建的数组打印到Excel

时间：2018-12-18 23:21:06

标签： arrays excel vba ms-word

我是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

4 个答案:

答案 0 :(得分：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

答案 1 :(得分：1)

这已经过测试，可以正常工作：

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

答案 2 :(得分：1)

问题中提供的代码存在一些问题，我已尝试根据问题描述进行纠正。

  1. 代码声明了许多对象变量，并在与声明相同的行中分配了它们，但是从未使用过这些对象。为了提高代码的可读性并使这些对象“显而易见”，我已将实例化移至新行。
  2. 然后，下面的示例代码将这些对象替换为原始代码中要使用的ActiveDocument...对象。这使代码更易读，更高效。
  3. 在代码的上下文中使用StoryRanges值得怀疑。 StoryRanges与Sentences不同。假设使用StoryRanges是一种误解或错别字，我将代码更改为使用Sentences。如果要使用StoryRanges，则代码可以在它们之间循环，但是需要进行某些结构上的更改。 （StoryRanges使代码可以访问文档的所有部分，例如TextBoxes，页眉，页脚，尾注-而不只是文档的主体。）
  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

答案 3 :(得分：-2)

一般的答案是使用Range ("A1") = myWords(ArrayCounter) 您需要在遍历数组的同时移至下一个单元格。

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

相关问题
最新问题