Home » excel » Using VBA, print an array made in Word to Excel

Using VBA, print an array made in Word to Excel

Posted by: admin May 14, 2020 Leave a comment

Questions:

I am a VBA novice and I am trying to print an array that I was able to make (basically copying from another post) in VBA today. I placed a break into the script and inspected the array in the locals page to see that the array captures what I want (and some extra data that I will filter out). I spent the day reading about printing arrays on stack overflow and other sites and I ended up a bit lost. My goal is to export the array as a table in excel.

The script looks for underlined sentences in a 400 page word document and places them into the array. All that’s really necessary for printing is the underlined sentences, so maybe an array wasn’t the best approach? How can I export the array ‘myWords’ to a fresh excel document or one that I designate?

Many thanks for your help!

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
How to&Answers:

This is tested and working fine :

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

Make sure to have the Microsoft Excel 14.0 Object Library ticked in Tools/References

Answer:

I prefer to use Late Binding over adding an external reference to Excel. This will allow the code to work properly no mater what version of Office is installed.

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:

The code provided in the question has some problems, which I’ve tried to correct as per the problem description.

  1. The code declares a number of object variables, assigning them in the same line as the declaration, but these objects are never used. In order to improve code readability and make these objects “obvious” I’ve moved the instantiations to new lines.
  2. The sample code below then substitutes these objects for the ActiveDocument... objects used in the original code, where these objects are intended to be used. This makes the code more readabile and more efficient.
  3. The use of StoryRanges is questionable in the context of the code. StoryRanges are not the same as Sentences. On the assumption that the use of StoryRanges was a misunderstanding or typo, I’ve changed the code to use Sentences. If StoryRanges is meant, the code can loop through them, but certain structural changes would be required. (StoryRanges enables code to access all parts of a document such as TextBoxes, Headers, Footers, Endnotes – instead of just the main body of the document.)
  4. It makes no sense to loop sentences while sizing the array to the number of words in the document. This has been changed to the number of sentences, which will require less memory.
  5. Only the text, not the entire sentence Range should be added to the array since Excel can’t do anything with a Word.Range except accept its text. This will require less memory.
  6. On the assumption that not every sentence in the document is underlined, it’s not necessary to maintain an array with empty members, so after the loop the array is resized to contain only those that have been populated. (ReDim Preserve myWords(ArrayCounter - 1)). This will avoid writing “empty” content to the Excel worksheet.
  7. The code to write to Excel is in a separate procedure, making it re-usable for other arrays that might need to be transferred to Excel. The code has been written as late-binding, making it independent of requiring a reference to the Excel library. If early-binding (with a reference) is desired, those declarations are commented out in-line.

  8. The writing to Excel only occurs if the array contains members. If ArrayCounter has never been incremented, the call to the other procedure is not performed.

  9. The Excel objects are set to Nothing at the end of that procedure.

Note: The code posted in the question and used here picks up any sentence that contains an underline.

Sample code:

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:

The general answer is to use Range ("A1") = myWords(ArrayCounter)
You would need to step through the array while simultaneously moving to the next cell.

You could also use Range ("A1:B3") = myWords.