AW: Eintragungstabelle in Word übertragen
21.12.2016 12:17:01
fcs
Hallo Susi,
am "einfachsten" wird es, wenn die Daten in der Exceltabelle zeilenweise abarbeitet werden und dabei in den Word-Dokumenten jeweils eine passende Wordtabelle (4 Zeilen,2 Spalten) angelegt wird.
Beim Übertragen der Daten kann man die Spalten und Zeilen vertauschen.
Bei den Dateinamen der Worddateien musst du ggf. Anpassungen machen.
Ich hab ihn jetzt aus Datum (JJJJ-MM-TT)-Name-Zeilennummer zusammengesetzt.
Mit der Zeilennummer werden identische Namen oder Mehrfach-Ckeck-inns erfasst.
Den Archiv-Pfad musst du ggf. ebenfalls anpassen.
LG
Franz
Sub NachWordKopieren()
Dim wksData As Worksheet
Dim Zeile As Long, Spalte As Long
Dim strPath As String
Dim wdApp As Object
Dim wdDoc As Object 'Word.document
Set wksData = ActiveSheet
strPath = wksData.Parent.Path & "\Archiv" 'Verzeichnis zum Archivieren der Checkins
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
'Tabellen-Rahmen Optionen setzen
With wdApp.Options
.DefaultBorderLineStyle = 1 'wdLineStyleSingle
.DefaultBorderLineWidth = 4 'wdLineWidth050pt
.DefaultBorderColor = -16777216 'wdColorAutomatic
End With
With wksData
For Zeile = 2 To .Cells(1, 1).End(xlDown).Row
'neues Worddokument anlegen
Set wdDoc = wdApp.documents.Add
'Word-Tabelle mit 4 Zeilen und 2 Spalten anlegen
wdDoc.Tables.Add wdDoc.Range, 4, 2
With wdDoc.Tables(1)
'Spaltenbreiten anpassen
With .Columns(1)
.PreferredWidthType = 3 'wdPreferredWidthPoints
.PreferredWidth = wdApp.CentimetersToPoints(3)
End With
With .Columns(2)
.PreferredWidthType = 3 'wdPreferredWidthPoints
.PreferredWidth = wdApp.CentimetersToPoints(12)
End With
With .Borders(-1) 'wdBorderTop
.LineStyle = wdApp.Options.DefaultBorderLineStyle
.LineWidth = wdApp.Options.DefaultBorderLineWidth
.Color = wdApp.Options.DefaultBorderColor
End With
With .Borders(-2) 'wdBorderLeft
.LineStyle = wdApp.Options.DefaultBorderLineStyle
.LineWidth = wdApp.Options.DefaultBorderLineWidth
.Color = wdApp.Options.DefaultBorderColor
End With
With .Borders(-3) 'wdBorderBottom
.LineStyle = wdApp.Options.DefaultBorderLineStyle
.LineWidth = wdApp.Options.DefaultBorderLineWidth
.Color = wdApp.Options.DefaultBorderColor
End With
With .Borders(-4) 'wdBorderRight
.LineStyle = wdApp.Options.DefaultBorderLineStyle
.LineWidth = wdApp.Options.DefaultBorderLineWidth
.Color = wdApp.Options.DefaultBorderColor
End With
With .Borders(-5) 'wdBorderHorizontal
.LineStyle = wdApp.Options.DefaultBorderLineStyle
.LineWidth = wdApp.Options.DefaultBorderLineWidth
.Color = wdApp.Options.DefaultBorderColor
End With
With .Borders(-6) 'wdBorderVertical
.LineStyle = wdApp.Options.DefaultBorderLineStyle
.LineWidth = wdApp.Options.DefaultBorderLineWidth
.Color = wdApp.Options.DefaultBorderColor
End With
'Daten aus Zeile in Exceltabelle in Word-Tabelle übertragen
For Spalte = 1 To 4
'Spaltentitel in Spale 1 eintragen
.Cell(Spalte, 1).Range.Text = wksData.Cells(1, Spalte).Text
'Werte in Zeile in Spale 2 eintragen
.Cell(Spalte, 2).Range.Text = wksData.Cells(Zeile, Spalte).Text
Next Spalte
End With
'Worddokument speichern und schliessen
wdDoc.SaveAs2 Filename:=strPath & "\" & Format(Date, "YYYY-MM-DD") _
& "-" & .Cells(Zeile, 1).Text & Format(Zeile - 1, "-000") & ".docx", _
FileFormat:=16, _
Addtorecentfiles:=False '16 = wdFormatDocumentDefault
wdDoc.Close Savechanges:=False
Next Zeile
End With
'Word-Anwendung wieder beenden
wdApp.Quit
End Sub