AW: vba anpassen daten von excel nach word mit textmar
27.01.2014 14:35:57
excel
Hallo Rosch,
folgenden beiden Makros im Userform "frmWDBookmarks" musst du anpassen, um die Zellinhalte der Zeile an jeweils einer anderen Textmarke im Worddokument einzutragen.
Gruß
Franz
Private Sub cmdCreateNewDoc_Click()
'Neues Dokument (*.doc) auf Basis der
' Dokument-Vorlage (*.dot) erstellen
'Wenn keine Word-Instanz vorhanden ist, erstellen
If TypeName(m_objWDApp) "Application" Then
'Fehlerbehandlung aktivieren
On Error Resume Next
Set m_objWDApp = Nothing
'Word starten
Set m_objWDApp = CreateObject("Word.Application")
If Err.Number 0 Then
'Fehler
MsgBox "Konnte keine Verbindung zu Word herstellen !", _
vbOKOnly + vbCritical, mc_AppMsgTitle
End If
On Error GoTo 0
End If
'Wenn soweit alles OK...
If TypeName(m_objWDApp) = "Application" Then
'Word sichtbar machen
m_objWDApp.Application.Visible = True
'Wenn noch k e i n neues Dokument erstellt wurde oder das ggf.
'bereits von dieser VB-Anwendung erstellte Dokument manuell
'geschlossen wurde, neues Dokument erstellen
If TypeName(m_objWDDoc) "Document" Then
'Fehlerbehandlung aktivieren
On Error Resume Next
Set m_objWDDoc = Nothing
'Neues Dokument auf Basis der Vorlage erstellen
' und Verweis setzen
Set m_objWDDoc = m_objWDApp.Documents.Add( _
Template:=m_strTemplateFile, NewTemplate:=False)
'Wenn kein Fehler aufgetreten ist
If Err.Number = 0 Then
'Fenstereinstellungen
With m_objWDDoc
.ActiveWindow.View.Type = wdPageView
.ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
End With
'Word aktivieren
m_objWDApp.Application.Activate
Else
'Fehlermeldung ausgeben
MsgBox "Es konnte kein neues Dokument auf Basis " & _
"der Dokumentvorlage '" & mc_DocTemplate & _
"' erstellt werden!", vbOKOnly + vbCritical, _
mc_AppMsgTitle
End If
On Error GoTo 0
End If
' *******W I C H T I G *******************************&&&&&&&&&&&&&&&&&&&&&&
'======>>>>Text den T E X T M A R K E N zuweisen, wenn ein Dokument vorhanden ist,
'oder erstellt werden konnte
If TypeName(m_objWDDoc) = "Document" Then
With ActiveCell
AddTextToBookmarks "qsDoc", .Text 'Spalte A
'Namen der Textmarken in den folgenden Zeilen anpassen !!!
AddTextToBookmarks "qsDoc01", .Offset(0, 1).Text 'Spalte B
AddTextToBookmarks "qsDoc02", .Offset(0, 2).Text 'Spalte C
AddTextToBookmarks "qsDoc03", .Offset(0, 3).Text 'Spalte D
AddTextToBookmarks "qsDoc04", .Offset(0, 4).Text 'Spalte D
AddTextToBookmarks "qsDoc05", .Offset(0, 5).Text 'Spalte E
AddTextToBookmarks "qsDoc06", .Offset(0, 6).Text 'Spalte F
AddTextToBookmarks "qsDoc07", .Offset(0, 7).Text 'Spalte G
AddTextToBookmarks "qsDoc08", .Offset(0, 8).Text 'Spalte H
AddTextToBookmarks "qsDoc09", .Offset(0, 9).Text 'Spalte I
AddTextToBookmarks "qsDoc10", .Offset(0, 10).Text 'Spalte J
AddTextToBookmarks "qsDoc11", .Offset(0, 11).Text 'Spalte K
AddTextToBookmarks "qsDoc12", .Offset(0, 12).Text 'Spalte L
AddTextToBookmarks "qsDoc13", .Offset(0, 13).Text 'Spalte M
End With
ActiveWorkbook.Save
'datei speichern
Unload Me
End If
End If
End Sub
Private Sub AddTextToBookmarks(ByVal strBMName As String, _
ByVal strBMText As String)
Dim objBMRange As Word.Range 'Range-Objekt, hier Textmarken-Bereich
With m_objWDDoc
'Wenn die Textmarke existiert...
If .Bookmarks.Exists(strBMName) Then
'Verweis auf den Textmarke-Bereich setzen
Set objBMRange = .Bookmarks(strBMName).Range
'Text zuweisen
objBMRange.Text = strBMText
'Textmarke neu definieren
.Bookmarks.Add Name:=strBMName, Range:=objBMRange
'Verweis (Speicher) freigeben
Set objBMRange = Nothing
End If
End With
End Sub