ich habe ein Problem und hoffe mir kann jemand helfen. Ich möchte alle Tabellen aus einem Word Dokument in ein Excel file per VBA kopieren.
Das funktioniert an sich schon. Ich habe nur das Problem das einige der Tabellen in Word innerhalb von Textfeldern stehen.
Diese werden dann nicht kopiert. Wie kann ich nun zu den anderen Tabellen auch noch alle die in Textfelder sind in meine Excelmappe kopieren? Ich hoffe mit kann jemand helfen
Hier habe ich ein kleines Beispiel. Die ersten beiden Tabellen werden kopiert ie letzte nicht.
https://www.herber.de/bbs/user/113683.doc
Den Code habe ich aus einer anderen Fragestellung von jemandem angepasst:
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
Dim tab_anz As Integer
Dim i As Integer
Dim lz As Integer
On Error GoTo Fin
Set objApp = OffApp("Word")
lz = 1
If Not objApp Is Nothing Then
Set objDocument = objApp.Documents.Open _
("C:\Users\paula\Desktop\S2\mini2.doc")
tab_anz = objDocument.tables.Count
MsgBox tab_anz
For i = 1 To tab_anz
objDocument.tables(i).Range.Select
objDocument.tables(i).Range.Copy
Sheets(1).Cells(lz + 2, 1).PasteSpecial Paste:=xlPasteValues
lz = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
MsgBox lz
Next i
objDocument.Close False
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
Es wäre toll wenn mir jemand helfen kann
Liebe Grüße