Loop without Selecting Files: VBA Copy different Word files in a folder to Excel

Hi,

I'm a VBA newbie. I've failed to solve my problem on my own. Maybe you have an idea?
I'm trying to loop through all word files in a folder and copy the entire content to a new Excel worksheet in my Excel workbook.
I managed to get the copying done, but if I loop through the different files, I have to open them by clicking on each file. Is there a way to change my code so it opens them without clicking on it first?

My (pretty ugly) code:

Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Dim WordApp As Object, objDoc As Object
Dim wdFileName As Variant

Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:akr987DesktopTest Word"
MyFile = Dir(MyDir & "*.docx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""

wdFileName = Application.GetOpenFilename("Word Documents, *.doc*") 'MultiSelect:=True
Set WordApp = CreateObject("Word.Application")
Set objDoc = WordApp.Documents.Open(wdFileName)
WordApp.Visible = False

'With
WordApp.Selection.WholeStory
WordApp.Selection.Copy
ThisWorkbook.Sheets(Sheets.Count).Range("A1").PasteSpecial xlPasteValues

ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)


objDoc.Close False
WordApp.Quit SaveChanges:=wdDoNotSaveChanges

Set WordApp = Nothing
Set objDoc = Nothing


'End With
Application.DisplayAlerts = 1
MyFile = Dir()

Loop

End Sub

Please Login or Register  to view this content.

Found the answer: in case someone else needs this kind of code:


Sub LoopThroughFolder()

Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Dim WordApp As Object, objDoc As Object
Dim wdFileName As Variant

Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:akr987DesktopTest Word/"
MyFile = Dir(MyDir & "*.docx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""

wdFileName = MyDir & MyFile
Set WordApp = CreateObject("Word.Application")
Set objDoc = WordApp.Documents.Open(wdFileName)
WordApp.Visible = False

'With
WordApp.Selection.WholeStory
WordApp.Selection.Copy
ThisWorkbook.Sheets(Sheets.Count).Range("A1").PasteSpecial xlPasteValues

ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)


objDoc.Close False
WordApp.Quit SaveChanges:=wdDoNotSaveChanges

Set WordApp = Nothing
Set objDoc = Nothing


'End With
Application.DisplayAlerts = 1
MyFile = Dir()

Loop

End Sub