|
Liebe VBA-Profis,
folgende Problemstellung:
ich habe eine große Anzahl Fragebögen auszuwerten. Die Fragebögen sind in Word und enthalten jeweils mehrere hundert Text-Steuerelemente. Den Inhalt dieser Steuerelemnte möchte ich auslesen und in einer Excel-Tabelle darstellen, was mit dem Makro unten auch schon klappt.
Dabei gibt es aber drei Probleme. Das erste ist relativ simpel: im Moment stehen nach durchlaufen des Makros alle Werte aus allen Word-Dokumenten am Enden untereinander. Wie schaffe ich es, dass die Werte aus jedem Dokument in einer neuen Spalte erscheinen, das also nach Auslesen von Dokument 1 ein Sprung in die nächste leere Spalte ausgeführt wird uind hier die Werte aus Dokument 2 eingefügt werden?
Das zweite Problem ist vermutlich etwas komplexer: Die Dateien enthalten auch Tabellen mit mehreren Zeilen und Spalten. Diese sollten am Besten auch in der Excel wieder so dargestellt werden, also alle Werte aus den Steuerelementen einer Zeile nebeneinander in eine Zelle geschrieben werden, die Inhaltssteuerelemente aus der nächsten Zeile dann wieder nebeneinander in die Zelle darunter usw.
Das dritte Problem ist, dass die Words auch Inhaltssteuerelemente für wiederholte Abschnitte enthalten. Das heisst manche Tabellen enthalten in manchen ausgefüllten Fragebögen mehr Zeilen, als in anderen. Das würde zu verschiebungen in der Tabelle führen, wenn es nicht berücksichtigt wird. Das heisst das Makro sollte erkennen, wenn über so ein Inhaltsstuerelement eine zusätzliche Ziele eingefügt wurde und müsste dann in der finalen Excel-Tabelle in allen Spalten, in denen an dieser Stelle ncihts eingefügt wurde, eine Leerzelle in dieser Zeile einfügen, bei den anderen aber nicht.
Ich hoffe ihr versteht die Probleme und könnt mir helfen! Das wäre echt grandios und würde mein Leben leichter und mich zu einem sehr glücklichen Menschen machen!. Danke schon einmal im Voraus!
Viele Grüße
Franz
Option Explicit
Const wdContentControlCheckBox = 8
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 12.12.2012
' Purpose : Aus Worddokumenten Inhaltssteuerelemente auslesen...
'--------------------------------------------------------------------------
Public Sub Main()
' Dimensionieren der Variablen
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim conControl As Object
Dim lngLastRow As Long
Dim strDatei As String
Dim strPath As String
Dim objApp As Object
Dim lngCalc As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
' Die Excelapplikation wird ruhig gestellt
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Pfad anpassen - fester Pfad vorgeben
'strPath = "C:\Temp\Word\"
' Pfad anpassen - Worddateien sind im gleichen
'Verzeichnis wie diese Exceldatei
strPath = ThisWorkbook.Path & Application.PathSeparator
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
' Temporäres Tabellenblatt hinzufügen
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set wksSheet = ActiveSheet
strDatei = Dir$(strPath & "*.doc*", vbDirectory)
Do While strDatei <> ""
' Worddokument öffnen
Set objDocument = objApp.Documents.Open _
(strPath & strDatei)
' WENN vorhanden werden die Inhaltssteuerelemente ausgelesen
If objDocument.ContentControls.Count <> 0 Then
For Each conControl In objDocument.ContentControls
' Bestimme jetzt die Anzahl der Zeilen in Spalte A
With wksSheet
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1). _
End(xlUp).Row, .Rows.Count) + 1
End With
' Dateiname in die erste Zelle schreiben
wksSheet.Cells(lngLastRow, 1).Value = strDatei
' Pfad in den Kommentar schreiben
wksSheet.Cells(lngLastRow, 1).AddComment.Text _
strPath & strDatei
With conControl
If .Type = wdContentControlCheckBox Then
wksSheet.Cells(lngLastRow, 2).Value = _
"Typ: " & .Type
wksSheet.Cells(lngLastRow, 3).Value = _
"Tag: " & .Tag
wksSheet.Cells(lngLastRow, 4).Value = _
"Text: " & .Range.Text
wksSheet.Cells(lngLastRow, 5).Value = _
"Haken: " & .Checked
Else
wksSheet.Cells(lngLastRow, 6).Value = _
"Typ: " & .Type
wksSheet.Cells(lngLastRow, 7).Value = _
"Tag: " & .Tag
wksSheet.Cells(lngLastRow, 8).Value = _
"Text: " & .Range.Text
End If
End With
Next conControl
End If
' Worddokument ohne speichern schlissen
objDocument.Close False
' Die nächste Datei nehmen
strDatei = Dir$()
Set objDocument = Nothing
Loop
' Spaltenbreite automatisch setzen
wksSheet.Cells.EntireColumn.AutoFit
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
' Objektvariablen leeren
Set wksSheet = Nothing
Set objDocument = Nothing
Set objApp = Nothing
' Die Applikation aufwecken
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.CutCopyMode = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
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
' Ausgegeben in WORD per Debug.Print
' With conControl
' If .Type = wdContentControlCheckBox Then
' Debug.Print .Type & " - " & .Tag & _
' " - " & .Range.Text & " - " & .Checked
' Else
' Debug.Print .Type & " - " & .Tag & " - " & .Range.Text
' End If
' End With
' Ergibt für das Dokument im Anhang:
'0 - Titel - Titel
'1 - Auftragsart - Worum geht es?
'8 - - ? - Wahr
'8 - - ? - Falsch
'8 - - ? - Wahr
'8 - - ? - Wahr
'8 - - ? - Falsch
'8 - - ? - Falsch
'8 - - ? - Falsch
'1 - Leiter - Peter Muster
'1 - Auftraggeber - Peter Muster
'1 - Kunde - Kunde 1
'6 - Beginn - 20.12.2012
'6 - Ende - 21.12.2012
'0 - Problembeschreibung - Keine Probleme bekannt
'1 - Gesamtziel - Kein Ziel
'0 - Teilziele - Teilziel 1
'Teilziel 2
'Teilziel 3
'0 - Ergebnisse - Ergebnis 1
'Ergebnis 2
'0 - Leistungen - Leistung 1
'Leistung 2
'0 - Randbedingung - Randbedingung
'0 - Auftragsorganisation - Firma 1
'Peter Muster
'Abteilung 1
'Jobbezeichnung 1
'Firma 2
'Frank Muster
'Abteilung 2
'Jobbezeichnung 2
'1 - Kosten - 2000 Euro
'1 - Sonstiges - Keine weiteren Informationen
'1 - - Keine Anlagen
' Die Konstanten:
'wdContentControlBuildingBlockGallery = 5
'wdContentControlCheckBox = 8
'wdContentControlComboBox = 3
'wdContentControlDate = 6
'wdContentControlDropdownList = 4
'wdContentControlGroup = 7
'wdContentControlPicture = 2
'wdContentControlRichText = 0
'wdContentControlText = 1
|