VBA problem: Load Word doc into Excel word by word

[strattergize]

I have a Word doc that I would like to load into Excel (or Access, if needs be) word by word. So if the Word doc has 500 words spread over 50 lines and two pages, I would like the 500 words to appear in cells A1 through A500, one word per cell.

Any ideas? I'm not quite sure how to do it, but perhaps if I could feed each word in Microsoft Word into an Array, then I could have the Array be output in Excel.

Any suggestions would be appreciated. Thank you.

Jared

 

[RSXchin]

You just need to declare your word and document.

Sub replace2()
    For i = 1 To ActiveDocument.Words.Count
        Cells(1, i) = ActiveDocument.Words.Item(i)
    Next i
End Sub

 

[pbornemeier]

This works on documents that do not require answering a prompt when they are opened. If there are macros in the document, or it needs an response for some other reason, the code will hang.

Option Explicit
 
Sub GetWordDocWords()
    'You must add a reference to Microsoft Word x.x Object Library
 
    'From the VBA editor menu Tools | References... | (select 'Microsoft Word x.x Object Library' | OK
 
    'If opening the document in Word requires you to answer a prompt (enable content or some such)
    'this code will hang.  You can kill the WINWORD process in the Task Manager
 
    Dim appWD As Word.Application
    Dim sFilePath As String
    Dim sFileName As String
    Dim wdRange As Word.Range
    Dim wdSingleWord As Word.Range
    Dim lNextWriteLine As Long
    Dim lWordCount As Long
    Dim sFilePathName As String
    Dim iAnswer As Integer
 
    If Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
        iAnswer = MsgBox("There are data in column A.  Do you want to erase it?", vbYesNo, "Erase column A?")
        If iAnswer <> vbYes Then
            MsgBox "Process cancelled."
            GoTo End_Sub
        End If
        Columns(1).Cells.Clear
    End If
 
    sFilePathName = Application.GetOpenFilename("All Files (*.doc*), *.doc*")
    If sFilePathName = "" Then
        MsgBox "No file selected.  Cannot continue."
        GoTo End_Sub:
    End If
 
    If LCase(Mid(sFilePathName, InStrRev(sFilePathName, ".") + 1, 3)) <> "doc" Then
        MsgBox "A MSWord document was not selected.  Cannot continue."
        GoTo End_Sub
    End If
 
    Set appWD = CreateObject("Word.Application")
 
    'Uncomment next paragraph if you want to see document opened
'    appWD.Visible = True
'    With appWD
'        .WindowState = wdWindowStateNormal
'        .Resize Width:=InchesToPoints(6), Height:=InchesToPoints(4)
'    End With
 
    appWD.Documents.Open Filename:=sFilePathName, _
        ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
        WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
        wdOpenFormatAuto, XMLTransform:=""
 
    Set wdRange = appWD.Selection.Range
    wdRange.WholeStory
    lWordCount = wdRange.Words.Count
 
    If lWordCount > Rows.Count Then
        MsgBox "More than " & Rows.Count & " words in the document.  Cannot continue."
        GoTo End_Sub
    End If
 
    Application.ScreenUpdating = False
    lNextWriteLine = 1
    With ActiveSheet
        Range("A1").Select
        For Each wdSingleWord In wdRange.Words
             Cells(lNextWriteLine, 1).Value = wdSingleWord
             Application.StatusBar = lNextWriteLine & "/" & lWordCount
             lNextWriteLine = lNextWriteLine + 1
        Next wdSingleWord
    End With
 
End_Sub:
 
    Set wdRange = Nothing
    appWD.Quit
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub

 

[strattergize]

Thank you for both of your responses. I appreciate it.

rsxchin: I like the simplicity of how you approached it; unfortunately, my skills are not good enough to translate the code into what I'm trying to do.

pbornemeier: thank you for your thoughtful response. It was exactly what I needed and I was able to easily incorporate it. Thank you.

Jared