Seitenübertrag bzw. Seite2

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox
Bild

Betrifft: Seitenübertrag bzw. Seite2 von: stargate
Geschrieben am: 26.03.2005 20:08:31

Hallo nochmal da mir ja das letzte mal so super und schnell geholfen wurde hätte ich da noch ein problem.
Ich habe mir die Excel Vorlage "Rechnung" für mich passend zurecht geschnitten.
Nur jetzt habe ich das Problem, wenn mir der Platz auf der ersten Seite nicht mehr reicht, wie ich das jetzt in Excel umsetzte das er mir auomatisch nach dem letzten Eintrag eine neue Seite anlegt und gleich einen Übertrag des Gesamtbetrages der ersten Seite zum Anfang der zweiten Seite setzt.

Hat da einer eine Lösung für mein Problem oder ist das so kompliziert zum umsetzten?

Mfg Heinz

Bild


Betrifft: AW: Seitenübertrag bzw. Seite2 von: Ramses
Geschrieben am: 26.03.2005 22:13:58

Hallo

das geht nur mit einem Makro.
Dieses Makro gehört in ein Modul



Sub Test_HBreak_und_Teilsummen_setzen()
'Variablen deklarieren
Dim As Long
Dim myVB As Integer
Dim QE1 As Integer, QE2 As Integer, QE3 As String, QE4 As String
Dim RTsum As Long, CTsum As Integer, CTLeft As Integer, myPSum As Long
Dim InterSum As Double
Dim wks As String
'Variablen setzen
'Diese Variablen bitte an deine Bedürfnisse anpassen
RTsum = 0 'Nicht verändern
'----
'Hier die Variablen anpassen
wks = "Tabelle1" 'Tabelle in der die Daten stehen
'Spaltennummern definieren
'1 = A, 2 = B, 3 = C usw
CTsum = 8 'Spaltennummer in der die Teilsumme erstellt werden soll !!! Hier "I" !!!!
CTLeft = 1 'Spaltennummer der Spalte die summiert werden soll !!! Hier "H"
'-----
'Kontrolle
'-----
'Ausstieg definieren wenn nicht die richtige Tabelle gedruckt wird
If ActiveSheet.name <> wks Then
    GoTo EndCheck
End If
'Ausstieg wenn nur eine Seite gedruckt werden kann
If ExecuteExcel4Macro("Get.Document(50)") = 1 Then
    MsgBox ("Es kann nur eine Seite gedruckt werden" & Chr$(13) & "das Makro wird abgebrochen !")
    GoTo EndCheck
End If
'Fragen ob die Teilsummen erstellt werden sollen
QE1 = MsgBox("Sollen Teilsummen eingesetzt werden ?", vbCritical + vbYesNo, "Teilsummen setzen")
If QE1 = 7 Then
    GoTo EndCheck
End If
'Wohin soll die Zwischensumme
QE2 = MsgBox("Teilsummen in die Fusszeile einfügen ?", vbCritical + vbYesNo, "Teilsumme in Fusszeile oder Zelle")
If QE2 = 7 Then
    QE3 = InputBox("In welcher Spalte sollen die Zwischensummen stehen", "Summe", Right(Left(Cells(1, CTsum).Address, 2), 1))
    If IsNumeric(QE3) Then
        MsgBox ("Es sind nur Buchstaben als Spaltenbezeichnungen erlaubt." & Chr$(13) & "Makro wird abgebrochen")
        Exit Sub
    End If
    'Neue Zielspalte für Zwischensummen zufügen
    CTsum = Range(QE3 & "1").Column
End If
'Summe aus welcher Spalte
QE4 = InputBox("Welche Spalte soll summiert werden?", "Summe", Right(Left(Cells(1, CTLeft).Address, 2), 1))
If IsNumeric(QE4) Then
    MsgBox ("Es sind nur Buchstaben als Spaltenbezeichnungen erlaubt." & Chr$(13) & "Makro wird abgebrochen")
    Exit Sub
End If
'Neue Spalte zuweisen
CTLeft = Range(QE4 & "1").Column
If QE2 = 6 Then
    GoTo SumFusszeile
End If
'----
'Start
'----
'Teilsummen setzen in Zelle
'--------
'ACHTUNG:
' " Worksheets(wks).HPageBreaks.Item(1).Location "
'erwartet mindestens zwei Druckseiten,
'sonst wird ein falsches Ergebnis geliefert.
'Kein Workaround bekannt
'--------
SumZelle:
For n = 1 To ExecuteExcel4Macro("Get.Document(50)")
    If n = 1 Then
        myPSum = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64),1)") - 1
        Cells(myPSum, CTsum).FormulaR1C1 = "=SUM(R[-" & myPSum - 1 & "]C[" & CTLeft - CTsum & "]:RC[" & CTLeft - CTsum & "])"
        RTsum = myPSum
    Else
        Cells(myPSum, CTsum).FormulaR1C1 = "=SUM(R[-" & RTsum - 1 & "]C[" & CTLeft - CTsum & "]:RC[" & CTLeft - CTsum & "])"
    End If
    myPSum = myPSum + RTsum
Next n
'Nächsten Block überspringen
GoTo EndCheck
'----
SumFusszeile:
'Teilsummen setzen in Fusszeile
On Error Resume Next
For n = 1 To ExecuteExcel4Macro("Get.Document(50)")
    If n = 1 Then
        myPSum = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64),1)") - 1
        InterSum = Application.WorksheetFunction.Sum(Range(Cells(1, CTLeft), Cells(myPSum - 1, CTLeft)))
        RTsum = myPSum - 1
    Else
        InterSum = Application.WorksheetFunction.Sum(Range(Cells((myPSum - RTsum), CTLeft), Cells(myPSum - 1, CTLeft)))
    End If
    With ActiveSheet.PageSetup
        .LeftFooter = "Seite " & n & " von " & ExecuteExcel4Macro("Get.Document(50)")
        .RightFooter = InterSum
    End With
    'Hier das Hochkomma entfernen zum ausdrucken und vor die nächste
    'Zeile das Hochkomma setzen
    'ActiveWindow.SelectedSheets.PrintOut from:=n, To:=n, Copies:=1, Collate:=True
    '---
    ActiveWindow.SelectedSheets.PrintPreview
    '---
    myPSum = myPSum + RTsum
Next n
EndCheck:
End Sub

     Code eingefügt mit Syntaxhighlighter 2.5


Sollte ausreichend gut dokumentiert sein, um es an deine Bedürfnisse anzupassen.

Gruss Rainer


Bild


Betrifft: AW: Seitenübertrag bzw. Seite2 von: stargate
Geschrieben am: 27.03.2005 19:23:13

boh eh!!!!
das ist mir jetzt ein wenig zu hoch!
habe zwar schon ein wenig mit VB6 gearbeitet aber das sprengt jetzt echt meinen horizont!
finde da nicht einmal raus wann er mir die nächste seite an legt und sieht di dann genau so aus wie die erste seite?
Ich denke mal das werde ich hier nicht hin bekommen.


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Dateien öffnen ohne Pfad"