Excel in Word - Zeilen trennen | HERBERS Excel Forum

Hallo zusammen,
ich hab mal wieder ein Problem und komme sowas von nicht voran.
es ist für mich super-kompliziert.
ich hab eine excel-tabelle mit überschriften in spalte A, unterüberschriften in spalte B und ein paar datensätze direkt unter den unterüberschriften in spalte B.
aus diesen daten erstelle ich diagramme, auswertungen etc. aber das ist nicht relevant für mein problem.
ich kopiere diese daten per makro in word als eine tabelle.
das alles klappt. jetzt möchte ich aber nicht die ganze tabelle zusammen einfügen.
sondern nach den überschriften trennen, also mehrere kleine tabellen untereinander.
dabei kann es sein, dass eine überschrift gar nicht auftaucht. in der datei könnt ihr sehen, wie das ganze aufgebaut ist.
https://www.herber.de/bbs/user/93267.xlsx
es kann z.b. sein, dass unter Ü1 nicht ü1.1 (und somit auch nicht die datensätze zu dieser überschrift) sondern direkt ü1.2 kommt mit seinen datensätzen. oder aber direkt ü1.4 usw. das selbe gilt auch für Überschrift2. ü2.1 kann ausfallen und es kann direkt ü2.1 kommen.
jetzt möchte ich einfach die überschriften (und zugehörige zeilen darunter) als eine tabelle in word einfügen. dann die nächste überschrift genauso. dann die nächste usw.
das ganze soll halt nicht in EINER tabelle in word stehen. perfekt wäre, wenn die überschriften in word über die jeweiligen tabellen geschrieben werden, also nicht als eine tabellenzeile. aber dies ist dann eher ein nice-to-have.
kann mir bei diesem makro jemand helfen.
würde mich sehr darüber freuen.
grüße studyy

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'Erstellt unter Excel 2010 Sub Daten_nach_Word() Dim wks As Worksheet Dim Zeile As Long, Zeile1 As Long, Zeile2 As Long Dim wdPasteOption As Long Dim rngData As Range Dim strUeberschrift As String Dim wdApp As Object 'Word.Application Dim wdDoc As Object 'Word.Document Set wks = ActiveSheet 'Word-Anwendung kreieren Set wdApp = VBA.CreateObject("Word.Application") wdApp.Visible = True 'neues Dokument anlegen Set wdDoc = wdApp.Documents.Add(Template:="D:\Test\TestDoc.docx") 'Einfügeposition selektieren wdDoc.Range(wdDoc.Characters.Count - 1, wdDoc.Characters.Count - 1).Select wdPasteOption = 1 'DataType für PasteSpecial-Aktion in Word _ 9 = wdPasteEnhancedMetafile (Grafik) _ 0 = wdPasteOLEObject (Excel-Tabellenobject) _ 1 = wdPasteRTF (Rich-Text-Format) _ 10 = wdPasteHTML (HTML-Format) Zeile1 = 1: Zeile2 = 0 'Zeilenzähler für Datensätze zurücksetzen With wks 'Zeilen in Exeltabelle abarbeiten For Zeile = 1 To .UsedRange.Row + .UsedRange.Rows.Count If .Cells(Zeile, 1).Text "" And .Cells(Zeile, 2).Text = "" Then 'Hauptüberschrift strUeberschrift = .Cells(Zeile, 1).Text If Zeile2 > 0 Then Set rngData = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 8)) rngData.Copy wdApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteOption, _ Placement:=0, DisplayAsIcon:=False 'Placement: 0 =wdInLine wdApp.Selection.TypeParagraph End If 'Hauptüberschrfit einfügen wdApp.Selection.TypeParagraph wdApp.Selection.TypeText Text:=strUeberschrift wdApp.Selection.TypeParagraph Zeile1 = Zeile + 1: Zeile2 = 0 'Zeilenzähler für Datensätze neu setzen ElseIf .Cells(Zeile, 1).Text = "" And .Cells(Zeile, 2).Text = "" Then 'Zeile nach letzten Daten If Zeile2 > 0 Then 'Zellbereich mit Datensätzen setzen und kopieren Set rngData = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 8)) rngData.Copy wdApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteOption, _ Placement:=0, DisplayAsIcon:=False ' Placement: 0 =wdInLine wdApp.Selection.TypeParagraph End If Else 'Prüfen, ob Unterüberschrift oder Datensatz Select Case .Cells(Zeile, 2) 'Text in Spalte B Case "Adresse", "Ort", "Name", "Nummer" 'Unterüberschrift strUeberschrift = .Cells(Zeile, 2).Text If Zeile2 > 0 Then 'Zellbereich mit Datensätzen setzen und kopieren Set rngData = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 8)) rngData.Copy wdApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteOption, _ Placement:=0, DisplayAsIcon:=False 'Placement: 0 =wdInLine wdApp.Selection.TypeParagraph End If 'Unterüberschrfit einfügen wdApp.Selection.TypeText Text:=strUeberschrift wdApp.Selection.TypeParagraph Zeile1 = Zeile + 1: Zeile2 = 0 'Zeilenzähler für Datensätze neu setzen Case Else 'Datensatzzeile Zeile2 = Zeile End Select End If Next End With wdApp.Activate Set wdApp = Nothing: Set wdDoc = Nothing: Set wks = Nothing: Set rngData = Nothing Application.CutCopyMode = False End Sub

Hallo Studdy,
wenn die aus den Spaltenbreiten in Excel abgeleiteten Spaltenbreiten nach dem Einfügen nicht optimal sind, dann müssen die Breiten von Tabellen und Spalten nach dem Einfügen individuell angepasst werden.
Gruß
Franz

'Erstellt unter Excel 2010
Sub Daten_nach_Word()
Dim wks As Worksheet
Dim Zeile As Long, Zeile1 As Long, Zeile2 As Long
Dim wdPasteOption As Long
Dim rngData As Range
Dim strUeberschrift As String
Dim wdApp As Object 'Word.Application
Dim wdDoc As Object 'Word.Document
Dim intTabCount As Integer
Set wks = ActiveSheet
'Word-Anwendung kreieren
Set wdApp = VBA.CreateObject("Word.Application")
wdApp.Visible = True
'neues Dokument anlegen
Set wdDoc = wdApp.Documents.Add(Template:="C:\Users\Public\Test\TestDoc.docx")
'Einfügeposition selektieren
wdDoc.Range(wdDoc.Characters.Count - 1, wdDoc.Characters.Count - 1).Select
wdPasteOption = 1 'DataType für PasteSpecial-Aktion in Word _
9 = wdPasteEnhancedMetafile (Grafik) _
0 = wdPasteOLEObject (Excel-Tabellenobject) _
1 = wdPasteRTF  (Rich-Text-Format) _
10 = wdPasteHTML (HTML-Format)
Zeile1 = 1: Zeile2 = 0 'Zeilenzähler für Datensätze zurücksetzen
intTabCount = wdDoc.Tables.Count
With wks
'Zeilen in Exeltabelle abarbeiten
For Zeile = 1 To .UsedRange.Row + .UsedRange.Rows.Count
If .Cells(Zeile, 1).Text  "" And .Cells(Zeile, 2).Text = "" Then
'Hauptüberschrift
strUeberschrift = .Cells(Zeile, 1).Text
If Zeile2 > 0 Then
Set rngData = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 8))
rngData.Copy
wdApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteOption, _
Placement:=0, DisplayAsIcon:=False 'Placement: 0 =wdInLine
wdApp.Selection.TypeParagraph
End If
'Hauptüberschrfit einfügen
wdApp.Selection.TypeParagraph
wdApp.Selection.TypeText Text:=strUeberschrift
wdApp.Selection.TypeParagraph
Zeile1 = Zeile + 1: Zeile2 = 0 'Zeilenzähler für Datensätze neu setzen
ElseIf .Cells(Zeile, 1).Text = "" And .Cells(Zeile, 2).Text = "" Then
'Zeile nach letzten Daten
If Zeile2 > 0 Then
'Zellbereich mit Datensätzen setzen und kopieren
Set rngData = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 8))
rngData.Copy
wdApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteOption, _
Placement:=0, DisplayAsIcon:=False ' Placement: 0 =wdInLine
wdApp.Selection.TypeParagraph
End If
Else
'Prüfen, ob Unterüberschrift oder Datensatz
Select Case .Cells(Zeile, 2) 'Text in Spalte B
Case "Adresse", "Ort", "Name", "Nummer"
'Unterüberschrift
strUeberschrift = .Cells(Zeile, 2).Text
If Zeile2 > 0 Then
'Zellbereich mit Datensätzen setzen und kopieren
Set rngData = .Range(.Cells(Zeile1, 1), .Cells(Zeile2, 8))
rngData.Copy
wdApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteOption, _
Placement:=0, DisplayAsIcon:=False 'Placement: 0 =wdInLine
wdApp.Selection.TypeParagraph
End If
'Unterüberschrfit einfügen
wdApp.Selection.TypeText Text:=strUeberschrift
wdApp.Selection.TypeParagraph
Zeile1 = Zeile + 1: Zeile2 = 0 'Zeilenzähler für Datensätze neu setzen
Case Else
'Datensatzzeile
Zeile2 = Zeile
End Select
End If
'Prüfen ob sich die Tabellenanzahl geändert hat
If intTabCount  wdDoc.Tables.Count Then
intTabCount = wdDoc.Tables.Count
'Tabellenbreite und Spaltenbreiten der Tabelle einstellen
With wdDoc.Tables(intTabCount)
.AllowAutoFit = False
.PreferredWidthType = 3 '3 = wdPreferredWidthPoints
.PreferredWidth = Application.CentimetersToPoints(17)
.Columns.PreferredWidthType = 3 '3 = wdPreferredWidthPoints
.Columns(1).Width = Application.CentimetersToPoints(0.5)
.Columns(2).Width = Application.CentimetersToPoints(3.5)
.Columns(3).Width = Application.CentimetersToPoints(2)
.Columns(4).Width = Application.CentimetersToPoints(3)
.Columns(5).Width = Application.CentimetersToPoints(1.5)
.Columns(6).Width = Application.CentimetersToPoints(2.5)
.Columns(7).Width = Application.CentimetersToPoints(2)
.Columns(8).Width = Application.CentimetersToPoints(2)
End With
End If
Next
End With
wdApp.Activate
Set wdApp = Nothing: Set wdDoc = Nothing: Set wks = Nothing: Set rngData = Nothing
Application.CutCopyMode = False
End Sub

Beliebteste Forumthreads (12 Monate)

Excel in Word - Zeilen trennen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel in Word - Zeilen trennen

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

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread