|
Hallo!
Ich verwende bisher diesen Code um mehrere Tabellen einer Word Datei in Excel zu importieren. Das gute daran, die Sturktur der Tabelle bleibt erhalten. Schlecht ist aber, dass unzähliche Striche und Objekte mitkopiert werden. Ich möchte eigentlich nur die Werte der Tabelle kopieren. Mit Lösungen wie paste als "Text" oder diese Dinge, habe ich das Problem dass mir die Tabelle einfach in der Spalte A nach unten hin reinkopiert werden, also die Tabelle verliert ihre Struktur. Habt ihr eventuell eine Lösung? Danke!
'Word öffnen und kopieren und einfügen
Dim wb As Workbook
Dim sh As Worksheet
Set wb = ActiveWorkbook
'Set sh = wb.ActiveSheet
Set sh = wb.Sheets("ZV_Umrechnung_P5000")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = False
Btxt.Documents.Open word_path
Application.Wait Now + TimeValue("0:00:01")
If Left(Btxt.ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(1).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(1).Range.Copy
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(2).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(2).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(2).Range.Copy
'Application.Goto sh.Cells(60, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(3).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(3).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(3).Range.Copy
'Application.Goto sh.Cells(100, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(4).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(4).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(4).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(5).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(5).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(5).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(6).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(6).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(6).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(7).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(7).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(7).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(8).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(8).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(8).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(9).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(9).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(9).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
If Left(Btxt.ActiveDocument.Tables(10).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Art" And Left(Btxt.ActiveDocument.Tables(10).Cell(Row:=1, Column:=1).Range.Text, 3) <> "Ges" Then
Btxt.ActiveDocument.Tables(10).Range.Copy
'Application.Goto sh.Cells(150, 1)
Application.GoTo sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
sh.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Application.CutCopyMode = False
Btxt.Documents(word_path).Close SaveChanges:=False
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
|