AW: Daten aus Word Formularfeld in Excel
15.05.2008 20:43:25
fcs
Hallo Rainer,
hier mein Vorschlag. Es funktioniert wenn alle Formulardateien in einem Verzeichnis liegen und keine weiteren Word (*.doc) -Dateien im Verzeichnis sind. Falls du über den Namen excakt filtern kannst (z.B Form*.doc), dann könne auch weiter Worddateien im Verzeichnis sein.
Im makro muss du die Namen der Formularfelder anpassen und ggf. den Filter für die Word-Dateien.
Gruß
Franz
Sub WordFormulareAuslesen()
'Erstellt unter Excel 97 / Word 97
' Für Funktion des Makros muss im Excel VBA-Editor unter Extras-Verweise _
die Microsoft Word X.Y Object Library aktiviert werden
'Word muss vor dem Starten des Makros geöffnet sein!
Dim intI As Integer
Dim objWb As Workbook, objWks As Worksheet
Dim lngZeile As Long
Dim wdDok As Word.Document, strWorddatei As String
Dim varVerzeichnis As Variant
On Error GoTo Fehler
Set objWb = ActiveWorkbook
'Datei im Verzeichnis der Worddateien wählen
varVerzeichnis = Application.GetOpenFilename(FileFilter:="Worddateien (*.doc), *.Doc", _
Title:="Bitte eine Word-Datei im gewünschten Verzeichnis selektieren und 'Öffnen'")
If varVerzeichnis = False Then GoTo Beenden
'Verzeichnisname ermitteln aus Dateiname
Do Until Right(varVerzeichnis, 1) = "\"
varVerzeichnis = Left(varVerzeichnis, Len(varVerzeichnis) - 1)
Loop
varVerzeichnis = Left(varVerzeichnis, Len(varVerzeichnis) - 1)
'Tabellenblatt für Liste einfügen, _
hier kann natürlich auch ein vorhandenens Blatt gesetzt werden
Set objWks = objWb.Worksheets.Add(After:=objWb.Sheets(1), Type:=xlWorksheet)
With objWks
'Spalten formatieren
.Cells.VerticalAlignment = xlVAlignTop
With .Columns(1)
.NumberFormat = "@"
.ColumnWidth = 25
End With
With .Columns(2)
.NumberFormat = "DD.MM.YYYY"
.ColumnWidth = 12
End With
With .Columns(3)
.NumberFormat = "@"
.WrapText = True
.ColumnWidth = 50
End With
With .Columns(4)
.Style = "Standard"
.ColumnWidth = 10
End With
.Range(.Columns(1), .Columns(4)).AutoFit
'Titelzeile ausfüllen
lngZeile = 1
.Cells(lngZeile, 1) = "Dateiname"
.Cells(lngZeile, 2) = "Datum"
.Cells(lngZeile, 3) = "Anmerkung"
.Cells(lngZeile, 4) = "Erledigt"
Range("A2").Select
'1. Zeile Fenster fixieren
ActiveWindow.FreezePanes = True
End With
'Neue Datei zum Zusammenführen der Tabellen Dateien anlegen
Application.ScreenUpdating = False
'Worddateien im Verzeichnis Öffnen
strWorddatei = Dir(varVerzeichnis & Application.PathSeparator & "*.doc")
intI = 0 'Zähler für Worddateien
'Word Programmfenster aktivieren
Application.ActivateMicrosoftApp (xlMicrosoftWord)
Word.Application.ScreenUpdating = False
Do Until strWorddatei = ""
intI = intI + 1
Application.StatusBar = "Die " & intI & ". Datei wird bearbeitet, Dateiname: " _
& strWorddatei
'Datei mit komplettem Pfad
strWorddatei = varVerzeichnis & Application.PathSeparator & strWorddatei
'Worddatei öffnen
Set wdDok = Word.Documents.Open(FileName:=strWorddatei, ReadOnly:=True)
With wdDok
lngZeile = lngZeile + 1
objWks.Cells(lngZeile, 1) = wdDok.Name
If IsDate(.FormFields("Datum").Result) Then
objWks.Cells(lngZeile, 2) = CDate(.FormFields("Datum").Result) 'Datum
Else
objWks.Cells(lngZeile, 2) = .FormFields("Datum").Result
End If
objWks.Cells(lngZeile, 3) = .FormFields("Anmerkung").Result 'Anmerkung
'Checkbox auswerten
If .FormFields("Erledigt").Result = 1 Then 'Erledigt
objWks.Cells(lngZeile, 4) = "Ja"
Else
objWks.Cells(lngZeile, 4) = "Nein"
End If
.Close Savechanges:=False
End With
strWorddatei = Dir
Loop
Word.Application.ScreenUpdating = True
Word.Application.WindowState = wdWindowStateMinimize
Application.StatusBar = False
Application.ScreenUpdating = True
'Breite Spalte A anpassen
objWks.Columns(1).AutoFit
GoTo Beenden
Fehler:
Select Case Err.Number
Case 429
MsgBox "Fehler Nr. " & Err.Number & " ist aufgetretten" & vbLf & Err.Description _
& vbLf & vbLf & "Bitte Microsoft Word vor dem Starten des Makros öffnen!"
Case Else
MsgBox "Fehler Nr. " & Err.Number & " ist aufgetretten" & vbLf & Err.Description
End Select
Beenden:
Set objWb = Nothing: Set objWks = Nothing
Set wdDok = Nothing
End Sub