Word Formular zu Excel: Makro läuft nicht

Set wrdWordApplication = CreateObject("Word.Application") Set ofdDateiDialog = Application.FileDialog(msoFileDialogFilePicker) For Each cxmlCustomXML In docDocument.CustomXMLParts If cxmlCustomXML.BuiltIn = False Then Set nxmlXMLNode = cxmlCustomXML.SelectSingleNode(cXMLKnotenRoot) If Not nxmlXMLNode Is Nothing Then Exit For End If End If Next cxmlCustomXML If Not cxmlCustomXML Is Nothing Then pDatenAusXMLStrukturAuslesen cxmlvCustomXML:=cxmlCustomXML pDatenInExcelEinfügen End If gstrq007_1 = cxmlvCustomXML.SelectSingleNode(cXMLKnotenRoot & "/q007_1").Text gstrq007_2 = cxmlvCustomXML.SelectSingleNode(cXMLKnotenRoot & "/q007_2").Text gstrq007_3 = cxmlvCustomXML.SelectSingleNode(cXMLKnotenRoot & "/q007_3").Text Sheets("DatenAusWord").Select Range("A2").Select If Trim(ActiveCell.Value) "" Then Range("A1").Select Selection.End(xlDown).Select Else Range("A1").Select End If wrdWordApplication.Quit Set wrdWordApplication = Nothing

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Set wrdWordApplication = CreateObject("Word.Application") Set ofdDateiDialog = Application.FileDialog(msoFileDialogFilePicker) set docDocument = wrdWordApplication.ActiveDocument For Each cxmlCustomXML In docDocument.CustomXMLParts

Hallo Max,
ich hab den Code mal soweit angepasst, die Worddateien ausgewählt und abgearbeitet werden.
Du müsstets noch die Bezeichnung des Hauptknotens anpassen, dann sollte es funktionieren. Ich konnte oder besser wollte jetzt aber nicht auch noch die Worddatei nachbauen.
Gruß
Franz

'Deklaration Variablen für die Werte aus der Worddatei
Public gstrq007_1 As String
Public gstrq007_2 As String
Public gstrq007_3 As String
Public gstrq007_4 As String
Public gstrq007_5 As String
Sub aa()
Dim ofdDateiDialog As Object 'Office.FileDialog
Dim wrdWordapplication As Object
Dim docDocument As Object 'Word.Document
Dim cxmlCustomXML As Object, nxmlXMLNode As Object
Dim varItem As Variant
Const cXMLKnotenRoot As String = "?" 'Hier ? durch Bezeichnung des Hauptknotens  _
ersetzen
Set wrdWordapplication = CreateObject("Word.Application")
Set ofdDateiDialog = Application.FileDialog(msoFileDialogFilePicker)
With ofdDateiDialog
.Title = "Bitte Word-Dateien auswählen, deren Formulardaten eingelesen werden sollen"
.ButtonName = "Auswählen"
.InitialFileName = "*.doc*"
If .Show = -1 Then
'gewählte Word Dokumente abarbeiten
For Each varItem In .SelectedItems
Set docDocument = wrdWordapplication.Documents.Open(Filename:=varItem, ReadOnly:=True) _
For Each cxmlCustomXML In docDocument.CustomXMLParts
If cxmlCustomXML.BuiltIn = False Then
Set nxmlXMLNode = cxmlCustomXML.SelectSingleNode(cXMLKnotenRoot)
If Not nxmlXMLNode Is Nothing Then
Exit For
End If
End If
Next cxmlCustomXML
If Not cxmlCustomXML Is Nothing Then
pDatenAusXMLStrukturAuslesen cxmlvCustomXML:=cxmlCustomXML
pDatenInExcelEinfügen
End If
docDocument.Close savechanges:=False
Next varItem
End If '.Show = -1
End With 'ofdDateiDialog
wrdWordapplication.Quit
Set wrdWordapplication = Nothing
End Sub
Sub pDatenAusXMLStrukturAuslesen(cxmlvCustomXML As Variant)
gstrq007_1 = cxmlvCustomXML.SelectSingleNode(cXMLKnotenRoot & "/q007_1").Text
gstrq007_2 = cxmlvCustomXML.SelectSingleNode(cXMLKnotenRoot & "/q007_2").Text
gstrq007_3 = cxmlvCustomXML.SelectSingleNode(cXMLKnotenRoot & "/q007_3").Text
End Sub
Sub pDatenInExcelEinfügen()
Dim Zelle As Range
Dim wks As Worksheet
Set wks = ActiveWorkbook.Sheets("DatenAusWord")
With wks
.Select
Set Zelle = .Range("A2")
If Trim(Zelle)  "" Then
Set Zelle = Zelle.Offset(-1, 0).End(xlDown).Offset(1, 0)
End If
Zelle.Value = gstrq007_1
Zelle.Offset(0, 1).Value = gstrq007_2
Zelle.Offset(0, 2).Value = gstrq007_3
'usw eintragen der Werte in Exceltabelle
'falls die Werte aus Word Zahlen oder Datums/Zeitwerte sind, dann _
müssen die Texte entsprechend konvertiert werden _
z.B.:
If IsNumeric(gstrq007_4) Then
Zelle.Offset(0, 3).Value = CDbl(gstrq007_4)
Else
Zelle.Offset(0, 3).Value = gstrq007_4
End If
If IsDate(Replace(gstrq007_5, "T", " ")) Then
Zelle.Offset(0, 4).Value = CDate(Replace(gstrq007_5, "T", " "))
Else
Zelle.Offset(0, 4).Value = gstrq007_5
End If
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Word Formular zu Excel: Makro läuft nicht

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread