Seitenumbruch in Excel soll neue Tabelle sein

Hallo zusammen,
ein Kollege trat gerade an mich ran und hatte gefragt, ob es möglich ist, eine Exceltabelle die 53 Seiten hat entsprechend aufzuteilen, so dass nicht alle 53 Seiten in einer Tabelle sind, sondern jedes mal, wo ein Seitenumbruch ist, eine neue Tabelle anfängt.

Kennt jemand so eine Möglichkeit? (Ich vermute mal es würde in Richtung VBA gehen?)

Noch mal zusammen fassend erklärt: Jedesmal wenn ein Seitenwechsel kommt, soll er eine neue Tabelle erstellen. So dass ich nachher meine 53 Tabellen anstelle einer habe.

Gruß

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 249665

Url: https://administrator.de/forum/seitenumbruch-in-excel-soll-neue-tabelle-sein-249665.html

Ausgedruckt am: 14.04.2025 um 02:04 Uhr

10 Kommentare

Neuester Kommentar

malzeit,

warum? (haha)
geht es darum dann beim ausdruck 53 zettel zu haben mit tabellenköpfen?

Hallo killtec,
benötigt er das für den Druck ? Also die Spaltenüberschriften lassen sich ja für den Druck auf jeder Seite automatisch wiederholen (Druckoptionen > Seite einrichten > Tab: Blatt "Wiederholungszeilen" ), falls es das ist was er gesucht hat ?!

Falls er es wieder erwarten doch so benötigt, mit VBA sollte das kein Problem darstellen. Kommt dann drauf an ob er mir richtigen Tabellen (Funktion als Tabelle formatieren) arbeitet oder ob die Tabelle nur ein normaler Bereich ist.

Grüße Uwe

Zitat von @colinardo:

Hallo killtec,
benötigt er das für den Druck ? Also die Spaltenüberschriften lassen sich ja für den Druck auf jeder Seite
automatisch wiederholen (Druckoptionen), falls es das ist was er gesucht hat ?!

war auch mein Ansatz

Hallo zusammen,
gemeint ist nicht der Druck. Es soll jede Seite so "umformatiert" werden, dass aus der jetzt momentan einzigen Tabelle 53 Tabellen entstehen. Trennpunkt wäre der Seitenumbruch.

Gruß

Zitat von @killtec:
Hallo zusammen,
gemeint ist nicht der Druck. Es soll jede Seite so "umformatiert" werden, dass aus der jetzt momentan einzigen Tabelle
53 Tabellen entstehen. Trennpunkt wäre der Seitenumbruch.

OK, ich habe das jetzt so interpretiert, dass eine lange Tabelle die auf dem ersten Tabellenblatt liegt, anhand der horizontalen Zeilenumbrüche in neue Tabellenblätter aufgesplittet werden soll: split_table_to_worksheets_249665.xlsm
(Im Sheet habe ich mal auf jedem neuen Blatt die Überschriften mit übernommen - lässt sich aber einfach abändern wenn man das nicht möchte)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Sub SplitTableOnHorizontalPageBreaks()
    Dim ws As Worksheet, rngHeaders As Range, rngPBStart As Range, newWS As Worksheet, pbRow As Long, maxCol As Long, maxRow As Long, rngTable As Range, curCell As Range
    'Sheet der Tabelle festlegen  
    Set ws = Worksheets(1)
    'Bereich der Tabelle festlegen  
    Set rngTable = ws.UsedRange
    'maximale Spalte der Tabelle  
    maxCol = rngTable.Cells(1, rngTable.Columns.Count).Column
    'max Zeile der Tabelle  
    maxRow = rngTable.Cells(rngTable.Rows.Count, 1).Row
    'Bereich der Überschriften  
    Set rngHeaders = rngTable.Rows(1)
    
    'letzte Zelle auf dem Sheet selektieren (wegen einem Bug siehe: http://support.microsoft.com/kb/210663/de)  
    ws.Range("IV65536").Select  
    
    ' Für jeden horizontalen PageBreak ...  
    For i = 0 To ws.HPageBreaks.Count - 1
        If i = 0 Then
            'Der Tabellenanfang hat keinen Pagebreak, also nehme die erste Zelle nach den Überschriften als Start für den zu kopierenden Bereich  
            Set rngPBStart = rngTable.Rows(2)
        Else
            Set rngPBStart = ws.HPageBreaks(i).Location
        End If
        If i < ws.HPageBreaks.Count - 1 Then
            'Wenn noch genügend PageBreaks vorhanden sind nehme den nächsten als Begrenzung  
            pbRow = (ws.HPageBreaks(i + 1).Location.Row) - 1
        Else
            'ansonsten nehme den übrig gebliebenen Rest  
            pbRow = maxRow
        End If
        'neues Sheet hinzufügen  
        Set newWS = Worksheets.Add(After:=Sheets(Sheets.Count))
        'Name des neuen Sheets setzen  
        newWS.Name = "Part_" & (i + 1)  
        'Überschriften in das neue Worksheet übernehmen  
        rngHeaders.Copy newWS.Range("A1")  
        'Daten in das neue Sheet kopieren  
        ws.Range(rngPBStart, ws.Cells(pbRow, maxCol)).Copy newWS.Range("A2")  
        
        'Spaltenbreiten anpassen  
        For x = 1 To rngTable.Columns.Count
            newWS.Columns(x).ColumnWidth = rngTable.Columns(x).ColumnWidth
        Next
    Next
    'Startsheet wieder selektieren  
    ws.Select
    ws.Range("A1").Select  
End Sub

Grüße Uwe

Hi Uwe,
das geht genau in die richtige Richtung.
Habe jetzt nur noch das Problem, dass nur die erste Spalte betrachtet wird. An welcher Ecke muss ich drehen, dass alle vier Spalten mit genommen werden?
Kann man auch irgendwie die Spaltenbreiten mit übernehmen?

Gruß

Zitat von @killtec:

Hi Uwe,
das geht genau in die richtige Richtung.
Habe jetzt nur noch das Problem, dass nur die erste Spalte betrachtet wird. An welcher Ecke muss ich drehen, dass alle vier
Spalten mit genommen werden?
Kann man auch irgendwie die Spaltenbreiten mit übernehmen?

Wie sieht die Tabelle aus ? Haben alle Spalten Überschriften ? Das ermittelt das Script normalerweise automatisch, außer an der Tabelle ist etwas merkwürdiges, oder eine ganz leere Spalte dazwischen.
Das Anpassen der Spaltenbreiten ließe sich auch anpassen.

Die Tabelle ist so aufgebaut:
1. Zeile(geht über 4 Spalten, die zusammen sind) = Überschrift
2. Zeile = leer
3. Zeile = Text | Text | Text | Text
restlichen Zeilen wie oben. Teilweise leere Zellen, jedoch mit Rand (Gitterlinien).

Gruß

OK, Code und Sheet sind angepasst.

Ich hatte noch mit einem ganz fiesen Bug zu kämpfen den ich zufällig hier entdeckt habe:
http://support.microsoft.com/kb/210663/de (ich dachte schon was ist den heute blos los ...diesmal waren die Jungs aus Redmond schuld )

Grüße Uwe

Hi Uwe,
habe das noch ein bisschen abgewandelt. Nun kopiert er mir die erste Überschrift nicht rein, aber bei einer Tabelle ist das kein Problem

Der wird manuell kopiert.
Die anderen Sachen kopiert er dann passend.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub SplitTableOnHorizontalPageBreaks()
    Dim ws As Worksheet, rngHeaders As Range, rngPBStart As Range, newWS As Worksheet, pbRow As Long, maxCol As Long, maxRow As Long, rngTable As Range, curCell As Range
    'Sheet der Tabelle festlegen  
    Set ws = Worksheets(1)
    'Bereich der Tabelle festlegen  
    Set rngTable = ws.UsedRange
    'maximale Spalte der Tabelle  
    maxCol = rngTable.Cells(1, rngTable.Columns.Count).Column
    'max Zeile der Tabelle  
    maxRow = rngTable.Cells(rngTable.Rows.Count, 1).Row
    'Bereich der Überschriften  
    Set rngHeaders = rngTable.Rows(1)
    
    'letzte Zelle auf dem Sheet selektieren (wegen einem Bug siehe: http://support.microsoft.com/kb/210663/de)  
    ws.Range("IV65536").Select  
    Z = 1
    ' Für jeden horizontalen PageBreak ...  
    For i = 0 To ws.HPageBreaks.Count - 1
        If i = 0 Then
            'Der Tabellenanfang hat keinen Pagebreak, also nehme die erste Zelle nach den Überschriften als Start für den zu kopierenden Bereich  
            Set rngPBStart = rngTable.Rows(2)
        Else
            Set rngPBStart = ws.HPageBreaks(i).Location
        End If
        If i < ws.HPageBreaks.Count - 1 Then
            'Wenn noch genügend PageBreaks vorhanden sind nehme den nächsten als Begrenzung  
            pbRow = (ws.HPageBreaks(i + 1).Location.Row) - 1
        Else
            'ansonsten nehme den übrig gebliebenen Rest  
            pbRow = maxRow
        End If
        'neues Sheet hinzufügen  
        Set newWS = Worksheets.Add(After:=Sheets(Sheets.Count))
        'Name des neuen Sheets setzen  
        newWS.Name = "Part_" & (i + 1)  
        'Überschriften in das neue Worksheet übernehmen  
        If Z = 1 Then
        
            rngHeaders.Copy newWS.Range("A1")  
            Z = 2
        End If
        'Daten in das neue Sheet kopieren  
        If Z = 2 Then
            ws.Range(rngPBStart, ws.Cells(pbRow, maxCol)).Copy newWS.Range("A1")  
        Else
            ws.Range(rngPBStart, ws.Cells(pbRow, maxCol)).Copy newWS.Range("A2")  
        End If
        'Spaltenbreiten anpassen  
        For x = 1 To rngTable.Columns.Count
            newWS.Columns(x).ColumnWidth = rngTable.Columns(x).ColumnWidth
        Next
    Next
    'Startsheet wieder selektieren  
    ws.Select
    ws.Range("A1").Select  
End Sub