Word Tabellen auslesen
22.09.2023 15:07:58
Frank
ich habe hier im Forum schon etwas zum Auslesen von Word-Tabellen gefunden.
Allerdings funktioniert das nur, wenn in den Word-Tabellen alle Spalten die gleiche Anzahl von Zeilen enthält.
Meine Word-Tabellen(und davon gibt es viele, in reichlich Word-Dateien) haben immer 3 Spalten und nur Spalte3 enthält eine unterschiedliche Anzahl an Zeilen.
Wie kann ich es umsetzten, dass jede Zeile aus der Spalte 3 in der Word-Tabelle, in jeweils eine darauffolgende Spalte in meiner Excel-Tabelle kopiert wird?
Hier mal mein Code
Sub uebertragen()
Dim I, Cellcount, RowsCount As Integer
Dim EX As Excel.Application
Dim objDoc As Word.Document
Dim objTab As Word.Table
Dim WB As Workbook
Dim WS As Worksheet
Dim strPath, strTMP, Datei, Datei1 As String
Dim intI As Integer
Dim fso As Object, File As Object
Dim varInhalt, lngZeile As Long, lngSpalte As Long
strPath = ("N:\CAS\Leitung\BPA\GQM\QM\PFAS")
Datei1 = "Kopie00 Comments submitted to date on restriction report.xlsm"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each File In fso.GetFolder(strPath).Files
If fso.GetExtensionName(File) = "docx" And Left(File.Name, 19) = "rest_pfas_rcom_part" Then intI = intI + 1
Next File
Set fso = Nothing
lngZeileExcel = 2
For I = 1 To intI
Datei = "rest_pfas_rcom_part" & I & ".docx"
On Error Resume Next
lngZeileExcel = 2
Set objDoc = Word.Documents.Open(Filename:=strPath & "\" & Datei, ReadOnly:=True)
With WB(Datei1).WS(2)
Set objTab = objDoc.Tables(iTab)
For iTab = 1 To objDoc.Tables.Count
Set objTab = objDoc.Tables(iTab)
For lngZeile = 1 To objTab.Rows.Count
lngSpExcel = 9
For lngSpalte = 1 To objTab.Columns.Count '1. Spalte in die Woedinhalte eingetragen werden sollen
varInhalt = objTab.Cell(lngZeile, lngSpalte).Range.Text 'Inhalt Wordzelle
varInhalt = Left(varInhalt, Len(varInhalt) - 2) 'letzte beiden Zeichen abschneiden
Cells(lngZeileExcel, lngSpExcel).Value = varInhalt 'in Exceltabelle eintragen
lngSpExcel = lngSpExcel + 1 'nächste Einfüge Spalte im Exelblatt
Next
lngZeileExcel = lngZeileExcel + 1
Next
Next
End With
objDoc.Close savechanges:=False
Next
End SubVorab schon mal vielen Dank und ein schönes Wochenende
Gruß
Frank