Tabelle formatiert an Word übergeben

Forumthread: Tabelle formatiert an Word übergeben

11.01.2022 13:19:57

Jenny

Hallo Ihr Lieben,
ich brauche eure Hilfe. Ich bin leider noch nicht ganz so drin in der VBA Programmierung. Daher wäre ich euch für eure Hilfe sehr dankbar.
Ich möchte gerne von mehrere Tabellen (Anzahl variabel, mit variablen Zeilen) die Spalten A,C und D in ein neues Word Dokument kopieren (nur von der Zusammenfassung ganz am Ende Spalte A und C). Das funktioniert auch soweit. Nur, dass ich alle einzelnen Tabellen als eine Tabelle im Word erhalte... Nun möchte ich aber, dass die Tabellen einzeln übertragen werden, die (Zwischen-)Überschriften und jeweils die letzte Zeile in einem bestimmten Format in Word eingefügt werden. Wie die Tabellen dann in Word aussehen sollen seht ihr in der Datei auf der rechten Seite an einem Bespiel.
https://www.herber.de/bbs/user/150326.xlsx
In Word:
Hauptüberschrift und letzte Zeile = Hintergrundfarbe Dunkelblau (0,56,106) - Schrift Fett und weiß
Zwischenüberschrift = Hintergrundfarbe Dunkelgrau (166,166,166) - Schrift Fett und Schwarz - & alle Zelle in dieser Zeile verbinden.
"Ende"-Zwischenüberschrift = Hintergrundfarbe Hellgrau (217,217,217) - Schrift Fett und Schwarz
Alle anderen Zellen = Hintergrundfarbe Türkis (195,222,209) - Schrift Schwarz
Erste Spalte Breite = 10,49
Zweite Spalte Breite = 2
Dritte Spalte Breite = 3,15
Für die Zusammenfassung
Erste Spalte Breite = 4,48
Zweite Spalte Breite = 11,47
Alle Tabellenlinien in weiß.
Ich dachte man könnte es so machen: übertrage die Tabellen in ein neues Word und durchsuche die Tabellen nach Text = XY und formatiere diese Zeile so".
Die unten stehende Makro wird durch einen button auf dem Tabellenblatt gestartet.
Könnt ihr mir hier helfen?


Sub AngebotErstellen()
Dim xlWks As Worksheet
Dim xlZeile As Long, xlZeile_L As Long
Dim wdApp As Object  'Word.Application
Dim wdDoc As Object  'Word.Document
Dim wdTab As Object  'Word.Table
Dim wdZeile As Long
Dim strDot As String
Set xlWks = ActiveSheet
strDot = ' in ein neues Word Dok übertragen muss nicht .dot sein
Set wdApp = VBA.CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add(Template:=strDot)
Set wdTab = wdDoc.Tables(4) 'in dem neuen Dok noch keine Tabelle dann vorhanden ... Tables(1)? 
With xlWks
xlZeile_L = .Cells(.Rows.Count, 2).End(xlUp).Row
With wdTab
For xlZeile = 2 To xlZeile_L
If xlZeile > 2 Then
.Rows.Add
End If
wdZeile = .Rows.Count
.Cell(wdZeile, 1).Range.Text = xlWks.Cells(xlZeile, 1).Text
.Cell(wdZeile, 2).Range.Text = xlWks.Cells(xlZeile, 3).Text
.Cell(wdZeile, 3).Range.Text = xlWks.Cells(xlZeile, 4).Text
Next
End With
End With
ActiveWorkbook.Activate
MsgBox "Fertig!", vbInformation, "Übertragung in Word-Vorlage"
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Tabelle formatiert an Word übergeben

11.01.2022 20:01:18

Dieter

Hallo Jenny,
für den Tabellenteil, den du als Muster in die Spalten F-H gestellt hast, kannst du das mit dem folgenden Programm machen. Der Rest sollte analog zu machen sein. Für die Zusammenfassung brauchst du eine 2. Tabelle.


Sub AngebotErstellen_Neu()
Dim pfad As String
Dim strDot As String
Dim suchErgebnis As Range
Dim wdApp As Object  'Word.Application
Dim wdDoc As Object  'Word.Document
Dim wdTab As Object  'Word.Table
Dim wdZeile As Long
Dim xlWks As Worksheet
Dim xlZeile As Long
Dim xlZeile_L As Long
pfad = ThisWorkbook.Path & "\"
strDot = pfad & "Jenny.dotx"
' "Jenny.dotx" enthält eine Tabelle mit nur einer Zeile und 3 Spalten
Set wdApp = VBA.CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add(Template:=strDot)
Set wdTab = wdDoc.Tables(1)
' Spaltenbreiten einstellen
wdTab.Columns(1).Width = wdApp.CentimetersToPoints(10.49)
wdTab.Columns(2).Width = wdApp.CentimetersToPoints(2)
wdTab.Columns(3).Width = wdApp.CentimetersToPoints(3.15)
Set xlWks = ThisWorkbook.Worksheets("Costs detailed")
Set suchErgebnis = xlWks.Columns("A").Find(What:="Total Study Preparation", _
LookIn:=xlValues, _
LookAt:=xlWhole)
If suchErgebnis Is Nothing Then
MsgBox """Total Study Preparation""" & " nicht gefunden"
Exit Sub
End If
xlZeile_L = suchErgebnis.Row
With xlWks
With wdTab
For xlZeile = 2 To xlZeile_L
If xlZeile > 2 Then
.Rows.Add
End If
wdZeile = .Rows.Count
.Cell(wdZeile, 1).Range.Text = xlWks.Cells(xlZeile, 1).Text
.Cell(wdZeile, 2).Range.Text = xlWks.Cells(xlZeile, 3).Text
.Cell(wdZeile, 3).Range.Text = xlWks.Cells(xlZeile, 4).Text
If xlZeile > 2 Then
If xlWks.Cells(xlZeile, "A").Font.Bold Then
If Left$(xlWks.Cells(xlZeile, "A"), 6)  "Total " Then
' Überschritfszeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(166, 166, 166) ' dunkelgrau
.Range.Font.Bold = True
End With
Else
' Summenzeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(217, 217, 217) ' hellgrau
.Range.Font.Bold = True
End With
End If
Else
' Datenzeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(195, 222, 209) ' türkis
.Range.Font.Bold = False
End With
End If
End If
Next xlZeile
End With
End With
' 1. Zeile formatieren
With wdTab.Rows(1)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
.Range.ParagraphFormat.Alignment = 1  ' 1 = wdAlignParagraphCenter
End With
' Letzte Zeile formatieren
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
End With
wdDoc.SaveAs2 Filename:=pfad & "Jenny.docx"
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
MsgBox "Fertig!", vbInformation, "Übertragung in Word-Vorlage"
End Sub

https://www.herber.de/bbs/user/150335.xlsm
Viele Grüße
Dieter

AW: Hut ab Dieter!!

12.01.2022 10:53:44

JoWE

Gruß
Jochen

AW: Tabelle formatiert an Word übergeben

12.01.2022 12:57:23

Jenny

Hallo Dieter,
erstmal tausend DANK!!! Das funktioniert schon mal super! :)
Ich habe nun versucht es - wie du geschrieben hast - für die anderen Tabellen analog zu machen.
Hier bin ich auf 2 Probleme gestoßen:
1. Wenn ich den Teil Study Preparation kopiere und für Project Management anpasse (habe ein neues Dim wdTab2 festgelegt damit er die PM Tabelle in die Tabelle 2 im Word überträgt), dann gibt er mir in der zweiten Tabelle auch Study Preparation und PM aus ... hängt das mit "xlWks.Colums.("A")" zusammen?
2. Ich möchte gerne, dass wenn z.B. die Tabelle Study Preparation nicht existiert, dass er mit trotzdem die PM Tabelle generiert.
Wäre es möglich, dass du mir hier nochmal weiterhilfst?
Ganz lieben Dank im Voraus
hier der Code, wie ich ihn um PM erweitert habe


Sub AngebotErstellen()
Dim pfad As String
Dim strDot As String
Dim suchErgebnis As Range
Dim wdApp As Object  'Word.Application
Dim wdDoc As Object  'Word.Document
Dim wdTab As Object  'Word.Table(1)
Dim wdTab2 As Object  'Word.Table(2) 'neu für PM Tabelle
Dim wdZeile As Long
Dim xlWks As Worksheet
Dim xlZeile As Long
Dim xlZeile_L As Long
pfad = ThisWorkbook.Path & "\"
strDot = pfad & "Jenny.dotx"
' "Jenny.dotx" enthält eine Tabelle mit nur einer Zeile und 3 Spalten
Set wdApp = VBA.CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add(Template:=strDot)
Set wdTab = wdDoc.Tables(1)
' Spaltenbreiten einstellen
wdTab.Columns(1).Width = wdApp.CentimetersToPoints(10.49)
wdTab.Columns(2).Width = wdApp.CentimetersToPoints(2)
wdTab.Columns(3).Width = wdApp.CentimetersToPoints(3.15)
Set xlWks = ThisWorkbook.Worksheets("Costs detailed")
Set suchErgebnis = xlWks.Columns("A").Find(What:="Total Study Preparation", _
LookIn:=xlValues, _
LookAt:=xlWhole)
If suchErgebnis Is Nothing Then
MsgBox """Total Study Preparation""" & " nicht gefunden"
Exit Sub
End If
xlZeile_L = suchErgebnis.Row
With xlWks
With wdTab
For xlZeile = 2 To xlZeile_L
If xlZeile > 2 Then
.Rows.Add
End If
wdZeile = .Rows.Count
.Cell(wdZeile, 1).Range.Text = xlWks.Cells(xlZeile, 1).Text
.Cell(wdZeile, 2).Range.Text = xlWks.Cells(xlZeile, 3).Text
.Cell(wdZeile, 3).Range.Text = xlWks.Cells(xlZeile, 4).Text
If xlZeile > 2 Then
If xlWks.Cells(xlZeile, "A").Font.Bold Then
If Left$(xlWks.Cells(xlZeile, "A"), 6)  "Total " Then
' Überschritfszeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(166, 166, 166) ' dunkelgrau
.Range.Font.Bold = True
End With
Else
' Summenzeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(217, 217, 217) ' hellgrau
.Range.Font.Bold = True
End With
End If
Else
' Datenzeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(195, 222, 209) ' türkis
.Range.Font.Bold = False
End With
End If
End If
Next xlZeile
End With
End With
' 1. Zeile formatieren
With wdTab.Rows(1)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
.Range.ParagraphFormat.Alignment = 1  ' 1 = wdAlignParagraphCenter
End With
' Letzte Zeile formatieren
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
End With
'PM
Set wdTab2 = wdDoc.Tables(2)
' Spaltenbreiten einstellen
wdTab2.Columns(1).Width = wdApp.CentimetersToPoints(10.49)
wdTab2.Columns(2).Width = wdApp.CentimetersToPoints(2)
wdTab2.Columns(3).Width = wdApp.CentimetersToPoints(3.15)
Set xlWks = ThisWorkbook.Worksheets("Costs detailed")
Set suchErgebnis = xlWks.Columns("A").Find(What:="Total Project Management", _
LookIn:=xlValues, _
LookAt:=xlWhole)
If suchErgebnis Is Nothing Then
MsgBox """Total Project Management""" & " nicht gefunden"
Exit Sub
End If
xlZeile_L = suchErgebnis.Row
With xlWks
With wdTab2
For xlZeile = 2 To xlZeile_L
If xlZeile > 2 Then
.Rows.Add
End If
wdZeile = .Rows.Count
.Cell(wdZeile, 1).Range.Text = xlWks.Cells(xlZeile, 1).Text
.Cell(wdZeile, 2).Range.Text = xlWks.Cells(xlZeile, 3).Text
.Cell(wdZeile, 3).Range.Text = xlWks.Cells(xlZeile, 4).Text
If xlZeile > 2 Then
If xlWks.Cells(xlZeile, "A").Font.Bold Then
If Left$(xlWks.Cells(xlZeile, "A"), 6)  "Total " Then
' Überschritfszeile
With wdTab2.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(166, 166, 166) ' dunkelgrau
.Range.Font.Bold = True
End With
Else
' Summenzeile
With wdTab2.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(217, 217, 217) ' hellgrau
.Range.Font.Bold = True
End With
End If
Else
' Datenzeile
With wdTab2.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(195, 222, 209) ' türkis
.Range.Font.Bold = False
End With
End If
End If
Next xlZeile
End With
End With
' 1. Zeile formatieren
With wdTab2.Rows(1)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
.Range.ParagraphFormat.Alignment = 1  ' 1 = wdAlignParagraphCenter
End With
' Letzte Zeile formatieren
With wdTab2.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
End With
'PM Ende
wdDoc.SaveAs2 Filename:=pfad & "Jenny.docx"
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
MsgBox "Fertig!", vbInformation, "Übertragung in Word-Vorlage"
End Sub

LG Jenny

AW: Tabelle formatiert an Word übergeben

12.01.2022 13:21:59

Jenny

Ich nochmal. Mir ist gerade ein Licht aufgegangen...
" Set suchErgebnis = xlWks.Columns("A").Find(What:="Total Study Preparation", _" legt das Ende fest .... Wenn ich hier einfach "Total Project Management" reinschreiben, dann ist das ja ein neues Ende ... ich bräuchte also für jede Tabelle auch einen Startpunkt ... richtig?
Nun weiß ich leider nicht wie man den festlegt...

AW: Tabelle formatiert an Word übergeben

12.01.2022 18:50:17

Dieter

Hallo Jenny,
ich habe das Programm so abgeändert, dass es
1. von einem leeren Word-Dokument startet und
2. 2 Tabellenbereiche bearbeitet
3. kein Problem damit hat, wenn einer der Tabellenbereiche (z.B. "Study Preparation") fehlt.
Die Anzahl der zu bearbeitenden Tabellenbereiche kannst du einfach erweitern, wenn du den folgenden Befehl erweiterst


suchBegriffe = Array("Study Preparation", "Project Management")

Es ist noch etwas an Ergänzung nötig, wenn du auch die Summary übernehmen willst, da hier ja andere Spaltenbreiten eingestellt werden müssen und nur 2 Werte übernommen werden.


Sub AngebotErstellen_Neu_2()
' Das Programm nutzt keine dotx-Datei, sondern erzeugt die benötigten
' Tabellen je nach Bedarf selbst
Dim anfZeile As Long
Dim endZeile As Long
Dim i As Long
Dim np As Long
Dim pfad As String
Dim rng As Object    ' Word.Range
Dim strDot As String
Dim suchBegriffe As Variant
Dim suchErgebnis As Range
Dim tb As Long       ' tb läuft über die zu übernehmenden Tabellen, hier von 0 bis 1
Dim wdApp As Object  ' Word.Application
Dim wdDoc As Object  ' Word.Document
Dim wdTab As Object  ' Word.Table
Dim wdZeile As Long
Dim xlWks As Worksheet
Dim xlZeile As Long
suchBegriffe = Array("Study Preparation", "Project Management")
Set xlWks = ThisWorkbook.Worksheets("Costs detailed")
pfad = ThisWorkbook.Path & "\"
Set wdApp = VBA.CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
For tb = LBound(suchBegriffe) To UBound(suchBegriffe)
' Anfangszeile bestimmen
Set suchErgebnis = xlWks.Columns("A").Find(What:=suchBegriffe(tb), _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not suchErgebnis Is Nothing Then
anfZeile = suchErgebnis.Row
' Endzeile bestimmen
Set suchErgebnis = xlWks.Columns("A").Find(What:="Total " & suchBegriffe(tb), _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not suchErgebnis Is Nothing Then
endZeile = suchErgebnis.Row
If Not anfZeile  anfZeile Then
.Rows.Add
End If
wdZeile = .Rows.Count
.Cell(wdZeile, 1).Range.Text = xlWks.Cells(xlZeile, 1).Text
.Cell(wdZeile, 2).Range.Text = xlWks.Cells(xlZeile, 3).Text
.Cell(wdZeile, 3).Range.Text = xlWks.Cells(xlZeile, 4).Text
If xlZeile > 2 Then
If xlWks.Cells(xlZeile, "A").Font.Bold Then
If Left$(xlWks.Cells(xlZeile, "A"), 6)  "Total " Then
' Überschritfszeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(166, 166, 166) ' dunkelgrau
.Range.Font.Bold = True
End With
Else
' Summenzeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(217, 217, 217) ' hellgrau
.Range.Font.Bold = True
End With
End If
Else
' Datenzeile
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(195, 222, 209) ' türkis
.Range.Font.Bold = False
End With
End If
End If
Next xlZeile
End With
End With
' 1. Zeile formatieren
With wdTab.Rows(1)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
.Range.ParagraphFormat.Alignment = 1  ' 1 = wdAlignParagraphCenter
End With
' Letzte Zeile formatieren
With wdTab.Rows(wdZeile)
.Shading.BackgroundPatternColor = RGB(0, 56, 106) ' Dunkelblau
.Range.Font.Bold = True
.Range.Font.ColorIndex = 8  ' 8 = wdWhite
End With
End If
End If
Next tb
' Speichern und Schließen
wdDoc.SaveAs2 Filename:=pfad & "Jenny.docx"
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
MsgBox "Fertig!", vbInformation, "Übertragung in Word-Dokument"
End Sub

https://www.herber.de/bbs/user/150353.xlsm
Viele Grüße
Dieter

AW: Tabelle formatiert an Word übergeben

13.01.2022 18:08:38

Jenny

Hallo Dieter,
es klappt!!!! :) Nochmal tausend Dank für deine Hilfe! Ich freu mich mega, dass es funktioniert!

Beliebteste Forumthreads (12 Monate)

Tabelle formatiert an Word übergeben

Forumthread: Tabelle formatiert an Word übergeben

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread