Tables from Word document to Excel

try this VBA Code...

Option Explicit
Dim blnTMP As Boolean
Public Sub Test()
Dim objDocument As Object
Dim strDatei As String
Dim strPfad As String
Dim objApp As Object
On Error GoTo Fin
' Pfad anpassen
strPfad = "C:\TMP\"
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
Do While strDatei <> ""
Set objDocument = objApp.Documents.Open _
(strPfad & strDatei)
' Die erste Tabelle wird kopiert
objDocument.Tables(1).Range.Copy
' Der gesamte Inhalt wird kopiert
'objDocument.Range.Copy
' und in ein neues Tabellenbatt eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Paste
' Worddokument ohne speichern schlissen
objDocument.Close False
' Die nächste Datei nehmen
strDatei = Dir$()
Loop
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set objApp = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function

Freehand fished from the Internet ... fresh 🙂

Nikolino
I know I don't know anything (Socrates)