Import text from MS Word documents into Excel

Option Explicit

Sub GetWordText()
  ' late binding
  Dim bWdRunning As Boolean
  Dim wdApp As Object
  Dim wdDoc As Object
  Dim wdDocName As String
  Dim wdText As String
  Dim rTarget As Range
  
  ' folder containing Word documents
  Const sPATH As String = "C:\test\"
  
  ' find first file
  wdDocName = Dir(sPATH & "*.doc")
  
  ' only continue if file is found
  If Len(wdDocName) > 0 Then
    
    ' reference running Word instance
    Set wdApp = GetObject(, "Word.Application")
    On Error Resume Next
    ' check if Word instance found
    If wdApp Is Nothing Then
      ' open new Word instance
      Set wdApp = CreateObject("Word.Application")
      bWdRunning = False
    Else
      bWdRunning = True
    End If
    On Error GoTo 0
    
    Do
      ' open Word document
      Set wdDoc = wdApp.documents.Open(sPATH & wdDocName)
      
      With wdDoc
        'get document contents
        wdText = .Range(0, .Characters.Count)
      End With
      
      ' determine target cell
      Set rTarget = ActiveSheet.Cells(65536, 1).End(xlUp)
      If Len(rTarget.Text) > 0 Then Set rTarget = rTarget.Offset(1, 0)
      
      ' populate cell
      rTarget.Value = wdText
      
      ' close Word document
      wdDoc.Close False
      
      ' find next file
      wdDocName = Dir
      ' exit if no more files
      If Len(wdDocName) = 0 Then Exit Do
    Loop
    
    ' clean up
    Set wdDoc = Nothing
    If Not bWdRunning Then wdApp.Quit
    Set wdApp = Nothing
  End If
  
End Sub