Sub GetDocContent()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, lRow As Long
Dim WkSht As Worksheet: Set WkSht = ActiveSheet
strFolder = "C:\Users\" & Environ("UserName") & "\Downloads\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
lRow = WkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
With wdDoc
.Range.Copy
WkSht.Paste WkSht.Range("A" & lRow)
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
Application.DisplayStatusBar = False
Application.EnableEvents = False
End Sub