|
Hallo gast,
du hast mir wirklich sehr geholfen. Vielen Dank :)
Ich habe deinen Code etwas für meine Bedürfnisse angepasst, womit ich eine Hilfstabelle mit Tabellenindex, Kapitel und Kapitelnummer anlege.
[code]
Sub kapitel()
Dim kapitel()
Dim tabkap()
Dim anzahl
Dim i As Long
Dim j As Long
'-------------------------------------------------
Dim wordDokument As Object
Dim wordDateiName As Variant
Dim tabellennummer As Integer 'Tabellennummer in Word
Dim iZeile_Excel As Long 'Zeilenindex in Excel
Dim iSpalte_Excel As Integer 'Spaltenindex in Excel
Dim iZeile_Excel_gesamt As Long
Dim Starttabelle As Integer
Dim Anzahl_Tabellen As Integer
Dim aktueller_Pfad As String
Dim k As Integer
Dim strKapitelNr As String
Dim compare_number As Integer
Dim string_len As Integer
Dim Test As String
Dim Test2 As String
'---------------------------------------------------
Worksheets("EPR_Word").Activate
aktueller_Pfad = ActiveWorkbook.Path
strDatei = Dir(aktueller_Pfad & "\" & "*.doc")
'wordDateiName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
'"EPR_Word Datei auswählen: ")
wordDateiName = aktueller_Pfad & "\" & strDatei
If TypeName(wordDateiName) Like "Boolean" Then
MsgBox "Keine Datei gefunden!", vbInformation
Exit Sub
End If
Set wordDokument = GetObject(wordDateiName) 'Worddatei öffnen
anzahl = wordDokument.Tables.Count
ReDim kapitel(1, 0)
kapitel(0, 0) = 0
For Each kap In wordDokument.Paragraphs
If kap.OutlineLevel < 10 And kap.Range.Text <> Chr(13) Then
kapitel(0, 0) = kapitel(0, 0) + 1
ReDim Preserve kapitel(1, kapitel(0, 0))
kapitel(0, kapitel(0, 0)) = kap.Range.Text
kapitel(1, kapitel(0, 0)) = kap.Range.Start
End If
Next kap
If anzahl > 0 Then
ReDim tabkap(anzahl)
For i = 1 To anzahl
For j = 1 To UBound(kapitel, 2)
If wordDokument.Tables(i).Range.Start < kapitel(1, 1) Then
tabkap(i) = "ohne Kapitel"
Else
If wordDokument.Tables(i).Range.Start > kapitel(1, j) Then
tabkap(i) = kapitel(0, j)
End If
End If
Next j
If tabkap(i) = "ohne Kapitel" Then
Else
Test = tabkap(i)
string_len = Len(Test)
Test = Left(Test, string_len - 1)
Sheets("Hilfstabelle ").Cells(i, 1) = i
Sheets("Hilfstabelle ").Cells(i, 2) = Test
For k = 1 To wordDokument.ListParagraphs.Count
With wordDokument.ListParagraphs(k)
Test2 = .Range
string_len = Len(Test2)
Test2 = Left(Test2, string_len - 1)
compare_number = StrComp(Test2, Test)
If compare_number = 0 Then
strKapitelNr = .Range.ListFormat.ListString & " "
Sheets("Hilfstabelle ").Cells(i, 3) = strKapitelNr
'Debug.Print strKapitelNr
End If
End With
Next k
End If
Next i
End If
End Sub
[/code]
Anschließend importiere ich alle Word-Tabellen in Excel und kenne auch dank Hilfstabelle die zugehörigen Kapitelnummer.
[code]
Option Explicit
Sub WordTabellenEinlesen()
Dim wordDokument As Object
Dim wordDateiName As Variant
Dim tabellennummer As Integer 'Tabellennummer in Word
Dim iZeile_Excel As Long 'Zeilenindex in Excel
Dim iSpalte_Excel As Integer 'Spaltenindex in Excel
Dim iZeile_Excel_gesamt As Long
Dim Starttabelle As Integer
Dim Anzahl_Tabellen As Integer
Dim aktueller_Pfad As String
Dim Test As String
Dim strDatei As String
On Error Resume Next
Excel.Application.ScreenUpdating = False
Clean_EPR_Word.Clean_EPR_Word 'vorheriges Löschen der gesamten Sheet
Worksheets("EPR_Word").Activate
aktueller_Pfad = ActiveWorkbook.Path
strDatei = Dir(aktueller_Pfad & "\" & "*.doc")
'wordDateiName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
'"EPR_Word Datei auswählen: ")
wordDateiName = aktueller_Pfad & "\" & strDatei
If TypeName(wordDateiName) Like "Boolean" Then
MsgBox "Keine Datei gefunden!", vbInformation
Exit Sub
End If
Set wordDokument = GetObject(wordDateiName) 'Worddatei öffnen
With wordDokument
tabellennummer = wordDokument.Tables.Count
Anzahl_Tabellen = wordDokument.Tables.Count
iZeile_Excel_gesamt = 0
For Starttabelle = 1 To Anzahl_Tabellen
With .Tables(Starttabelle)
Test = Left(Sheets("Hilfstabelle ").Cells(Starttabelle, 3), 1)
If Left(Sheets("Hilfstabelle ").Cells(Starttabelle, 3), 1) = "5" Then
ActiveDocument.Range.GoTo What:=wdGoToHeading
For iZeile_Excel = 1 To .Rows.Count
For iSpalte_Excel = 1 To .Columns.Count
Cells(iZeile_Excel_gesamt, iSpalte_Excel + 1) = WorksheetFunction.Clean(.Cell(iZeile_Excel, iSpalte_Excel).Range.Text)
Test = WorksheetFunction.Clean(.Cell(iZeile_Excel, iSpalte_Excel).Range.Text)
Next iSpalte_Excel
iZeile_Excel_gesamt = iZeile_Excel_gesamt + 1
Next iZeile_Excel
End If
End With
iZeile_Excel_gesamt = iZeile_Excel_gesamt + 1
Next Starttabelle
End With
Sheets("Vergleich").Select
Excel.Application.ScreenUpdating = True
MsgBox "... eingelesen!", , "Fertig"
End Sub
[/code]
Nochmal, vielen Dank und ein schönes Wochenende :)
|