title image


Smiley Re: Blattsumen einer großen Excel Tabelle nur beim Ausdruck ausgeben
Hallo,



setze diesen Code in das Ereignis "Before_Print" deiner Arbeitsmappe, dann wirst du vor jedem Ausdruck gefragt ob du Teilsummen haben willst oder nicht:





Private Sub Workbook_BeforePrint(Cancel As Boolean)

'Variablen deklarieren

Dim Cr As Long, CC As Integer, i As Long, n As Long

Dim myHB As Integer, myVB As Integer, QE As Integer

Dim RTsum As Long, CTsum As Integer, CTLeft As Integer, myPSum As Long

Dim pHb As HPageBreak

Dim wks As String

'Variablen setzen

'Diese Variablen bitte an deine Bedürfnisse anpassen

Cr = 65536 'Nicht verändern

CC = 1 'Nicht verändern

myHB = 0 'Nicht verändern

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 = 9 'Spaltennummer in der die Teilsumme erstellt werden soll !!! Hier "I" !!!!

CTLeft = 8 '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

'Fragen ob die Teilsummen erstellt werden sollen

QE = MsgBox("Sollen die Teilsummen eingesetzt werden ?", vbCritical + vbYesNo, "Teilsummen setzen")

If QE = 7 Then Exit Sub

'----

'Start

'----

'Letzte Zelle in Spalte CTLeft suchen

If Cells(Cr, CTLeft) = "" Then

    Cr = Cells(Cr, CTLeft).End(xlUp).Row

End If

'Anzahl horizontaler PageBreaks ermitteln

For i = 1 To Worksheets(wks).HPageBreaks.Count

    myHB = myHB + 1

Next i

'Teilsummen setzen

For n = 1 To myHB

    myPSum = Worksheets(wks).HPageBreaks.Item(n).Location

    If n = 1 Then

        Cells(myPSum - 1, CTsum).FormulaR1C1 = "=SUM(R[-55]C[" & CTLeft - CTsum & "]:RC[" & CTLeft - CTsum & "])"

    Else

        Cells(myPSum - 1, CTsum).FormulaR1C1 = "=SUM(RC[" & CTLeft - CTsum & "]:R[" & RTsum - myPSum + 1 & "]C[" & CTLeft - CTsum & "])"

    End If

    RTsum = myPSum

Next n

EndCheck:

End Sub 
Herzliche Grüsse

aus der Schweiz

Rainer

Kombiniere Geist und Google,...denn Wissen ist geil :-)



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: