Live-Forum - Die aktuellen Beiträge
Datum
Titel
20.04.2024 00:49:19
Excel Sheet in einen Excel Kalender einfügen
20.04.2024 00:08:11
In Ordner nur das Speichern von Dateien erlauben
19.04.2024 21:26:15
mehrfache Texte finden
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1864to1868
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1864to1868
1864to1868
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Tabelle formatiert an Word übergeben

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

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

Betreff
Datum
Anwender
Anzeige
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
Anzeige
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
Anzeige
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
Anzeige
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)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige