AW: Zitronen-Murkx
10.04.2017 11:23:41
Fennek
Hallo,
am Wochenende habe ich noch einen Code zum Einlesen der anderen Tabellen geschrieben. Als Basis zum Austesten könnte es reichen, als "copy/paste" wohl nicht.
Wer immer die Tabellen 1, 5 und 8 mit mehreren Überschriften in einer Tabelle konzipiert hat, hat richtig "gemurkxst", aber auch das kann man auslesen.
Ich habe eine kurzen Blick in die bereitgestellte xlsm-Datei geworfen: Nach meiner Ansicht MUSS ein Datensatz in EINE Zeile der Auswertung überführt werden!
Auch nach einigem NAchdenken habe ich keine andere Idee als einen Zitronen-Markt: es ist kein Geschäft zu machen, mein Code ist nicht gut genug um ihn zu verkaufen, geschenkt hilft er dir nicht, da du ihn vermutlich nicht anpassen kannst und ca 2 Stunden Prpgrammierarbeit sind für mich genug. Also bedanke ich mich für die realitätsnahe Aufgabe und die Unterhaltung/Übung.
mfg
Sub Fen()
'early binding: Verweis auf "MS Word" setzen
'Dim Wd As Object
Dim Wd As Word.Application
Dim Doc As Object
Dim Tb As Table
'dim Tb as object
Dim wC()
wC = Array(0, 4, 1, 3, 3, 3, 4, 3, 4)
Dim iPath As String, iFile As String
Dim xZ As Integer 'Zeile in xl
'Set Wd = CreateObject("Word.Application")
Set Wd = New Word.Application
iPath = ThisWorkbook.Path & "\"
xZ = 1
iFile = Dir(iPath & "*.docx")
Do While Len(iFile)
xZ = xZ + 1
Cells(xZ, xCol.ID) = xZ - 1
Cells(xZ, xCol.iFile) = iFile
Set Doc = Wd.Documents.Open(iPath & iFile, , 1)
Wd.Visible = True
'### Überschriften
If Cells(xZ, xCol.Tit + 1) = "" Then
With Doc.Content.Paragraphs
For iP = 1 To .Count
If .Item(iP).Style = "Überschrift 1" Then ' "Formatvorlage1" Then ' Unterpunkte
T = T + 1
Cells(xZ, xCol.Tit + T) = .Item(iP).Range.Text
End If
Next iP
End With
End If
'### Tabellen
With Doc
For iT = 1 To .Tables.Count
Select Case iT
Case Is = 1
Sp = xCol.Tab1
Case Is = 3
Sp = xCol.Tab3
Case Is = 4
Sp = xCol.Tab4
Case Is = 5
Sp = xCol.Tab5
Case Is = 6
Sp = xCol.Tab7
Case Is = 7
Sp = xCol.Tab7
Case Is = 8
Sp = xCol.Tab8
End Select
Select Case iT
Case Is = 2
For i0 = 1 To Doc.Tables(iT).Rows.Count
Cells(xZ, xCol.Tab2 + i0 - 1) = .Tables(iT).Cell(i0, wC(iT)). _
Range.Text
Next i0
Case Is = 1, 5, 8
For i0 = 1 To Doc.Tables(iT).Rows.Count
If i0 7 Then Cells(xZ, Sp + i0) = Val(.Tables(iT).Cell(i0, wC( _
iT) + 3).Range.Text)
Next i0
Case Else
For i0 = 1 To Doc.Tables(iT).Rows.Count
Cells(xZ, Sp + i0) = Val(.Tables(iT).Cell(i0, wC(iT)).Range. _
Text)
Next i0
End Select
Next iT
End With
Doc.Close 0
iFile = Dir
Loop
Fin:
Wd.Quit
Set Doc = Nothing
Set Wd = Nothing
End Sub