title image


Smiley Lange (Zeilen), schmale (Spalten) Tabellen aufteilen für Druck auf 1 Blatt
Hallo Tomi,



habe schon mal die analaloge Lösung gepostet für Tabellen die sehr breit aber nicht hoch sind.



Für die Tabelle wird ein separates Druckblatt erstellt, damit die Originaldaten unverändert bleiben. Die Anzahl der Blöcke nebeneinander ist variabel durch Usereingabe



Tabelle:



 AB1Nrbez21asdf32s43das54dfs65f76asdf87s98das109dfs1110f1211asdf1312s1413das1514dfs1615f1716asdf1817s1918das2019dfs2120f



Druckblatt:



 ABCDEFGH1Nrbez Nrbez Nrbez21asdf 7s 14dfs32s 8das 15f43das 9dfs 16asdf54dfs 10f 17s65f 11asdf 18das76asdf 12s 19dfs



und hier der code der's macht:





Sub drucken()

    'Erstellen eines Ausdruckblattes für lange aber schmale Tabellen

    'Spalten werden aufgeteilt um nebeneinder gedruckt werden zu können

    Dim Zeilen, Breite, Spalten, EinfSpalte, Hoehe, Zähler As Long

    Application.DisplayAlerts = False

    Application.ScreenUpdating = False

        On Error Resume Next

        'ggf. altes Druckblatt entfernen

        Sheets("Druck").Delete

        On Error GoTo 0

        'aus bestehenden Daten neues Blatt erstellen

        ActiveSheet.Copy After:=Sheets(Sheets.Count)

        ActiveSheet.Name = "Druck"

        'Anzahl der verwendeten Spalten und Zeilen ermitteln

        Spalten = [iv1].End(xlToLeft).Column

        Zeilen = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

        'Userabfrage in welcher Höhe die Tabelle getrennt werden soll

        'geht nur schwer automatisch da Zeilenhöhe variieren kann

        Hoehe = InputBox("Anzahl Zeilen für Trennung angeben" & Chr(10) & _

        "Es sind " & Zeilen & " Zeilen beschrieben" & Chr(10) & _

        Round(Zeilen / 2, 0) & " = 2 Blöcke nebeneinander" & Chr(10) & _

        Round(Zeilen / 3, 0) & " = 3 Blöcke nebeneinander" & Chr(10) & _

        Round(Zeilen / 4, 0) & " = 4 Blöcke nebeneinander", "Höhe", Round(Zeilen / 2, 0))

        Zähler = 1

        'Schleife für die Aufteilung

        For i = Spalten + 2 To Zeilen / Hoehe * (Spalten + 1) Step Spalten + 1

            'Überschriftenzeile kopieren

            Range(Cells(1, 1), Cells(1, Spalten)).Copy Destination:=Cells(1, i)

            'Daten kopieren

            Range(Cells(Hoehe * Zähler + 1, 1), Cells(Hoehe * Zähler + Hoehe, Spalten)).Copy Destination:=Cells(2, i)

            Zähler = Zähler + 1

        Next

        'nicht benötigte Daten löschen

        Range(Cells(Hoehe + 1, 1), Cells(65536, 256).Address(False, False, xlA1)).ClearContents

        'Spaltenbreite anpassen

        Cells.EntireColumn.AutoFit

        'Leerzeilen zwischen den Blocken schmaler einstellen und grau einfärben

        For i = 1 To [iv1].End(xlToLeft).Column

            If Cells(1, i) = "" Then

                Columns(i).ColumnWidth = 1

                Range(Cells(1, i), Cells(Hoehe, i)).Interior.ColorIndex = 15

            End If

        Next

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    'Fenster in Zeile 2 fixieren

    [a2].Select

    ActiveWindow.FreezePanes = True

End Sub

 Code eingefügt mit Syntaxhighlighter 1.16



Gruesse Georg




Beiträge zu Excel 2002 in Verbindung mit Win XP

 A
1Tabellentool
2von StrgAltEntf


Gibts hier


geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: