title image


Smiley Neue Variante...
Hallo Claus-Jürgen,



hier eine überarbeitete Version, es lies mir keine Ruhe :-)), um die Teilsumme wahlweise im rechten Teil der Fusszeile anzuzeigen.

Diese Variante läuft fehlerfrei.





Sub Test_HBreak_und_Teilsummen_setzen()

'Variablen deklarieren

Dim n 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

Cr = 65536 '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 = 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

'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

SumZelle:

For n = 1 To ExecuteExcel4Macro("Get.Document(50)")

    If n = 1 Then

        myPSum = Worksheets(wks).HPageBreaks.Item(1).Location - 1

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

        RTsum = myPSum

    Else

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

    End If

    myPSum = myPSum + RTsum

    Debug.Print myPSum

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 = Worksheets(wks).HPageBreaks.Item(1).Location

        InterSum = Application.WorksheetFunction.Sum(Range(Cells(1, CTLeft), Cells(myPSum - 1, CTLeft)))

        RTsum = myPSum - 1

    Else

        Debug.Print "myPSum " & myPSum

        Debug.Print "myPSum - RTsum " & myPSum - RTsum

        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 1.16




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: