ΑΘΡΟΙΣΜΑΤΑ ΑΝΑ ΣΕΛΙΔΑ ΣΕ ΕΚΤΥΠΩΣΗ ΑΡΧΕΙΟΥ Excel

[GEORGE1]

Καλημέρα,

 

Έχω ένα αρχείο Excel που αποτελείται απο αρκετές σελίδες ( 18 ),

Υπάρχει τρόπος κατά την εκτύπωσή του στο τέλος της κάθε σελίδας να προστίθενται τρείς γραμμές με αθροίσματα όπως παρακάτω : ????

Άθροισμα σελίδας

Αθροισμα προηγούμενων σελίδων

Άθροισμα για μεταφορά (στην επόμενη σελίδα να εμφανίζεται στο πεδίο Άθροισμα προηγουμένων σελίδων)

 

Ευχαριστώ

[UserXP]

Ένας γρήγορος τρόπος είναι χρησιμοποιώντας το footer

 

Βάλε τη παρακάτω sub σε ένα module, θέσε στη μεταβλητή ColumnToSum τον αριθμό της στήλης που θα αθροίζεται και τρέξε τον κώδικα.

>
Sub PrintSumPerPage()
Dim aSheet As Worksheet, ColumnToSum As Long
Dim i As Long, j As Long, fromRow As Long, toRow As Long
Dim aSum As Single, aSumBef As Single, aSumCur As Single
Dim OldFooter As String, aFooterText As String
   
   ' Εδώ δίνεις τον αριθμό στήλης που θα προσθέτεις
   ColumnToSum = 1
   
   Set aSheet = ActiveSheet
   ' Δείχνε τα PageBreaks
   aSheet.DisplayPageBreaks = True
   
   ' Αποθήκευσε το footer
   OldFooter = aSheet.PageSetup.RightFooter
       
   ' Activate το τελευταίο κελί για να λειτουργεί σωστά η HPageBreaks collection
   aSheet.Cells(aSheet.UsedRange.Rows.Count, 1).Activate
       
   fromRow = 1
   For j = 1 To aSheet.HPageBreaks.Count
       ' Αν το τελευταίο κελί είναι ακριβώς στο τέλος της τελευταίας σελίδας
       ' η aSheet.HPageBreaks.Count αυξάνεται κατά 1 αλλά
       ' η aSheet.HPageBreaks(aSheet.HPageBreaks.Count).Location.Row > aSheet.UsedRange.Rows.Count
       If aSheet.HPageBreaks(j).Location.Row <= aSheet.UsedRange.Rows.Count Then
           aFooterText = "Άθροισμα για μεταφορά = "
           toRow = aSheet.HPageBreaks.Item(j).Location.Row - 1
       Else
           aFooterText = "Τελικό Άθροισμα = "
           toRow = aSheet.UsedRange.Rows.Count
       End If
       
       GoSub PrintJob
   Next j
   
   ' Έχουμε PageBreaks;
   If aSheet.HPageBreaks.Count > 0 Then
       ' Υπάρχει τελευταία σελίδα να εκτυπώσω;
       If aSheet.HPageBreaks(aSheet.HPageBreaks.Count).Location.Row <= aSheet.UsedRange.Rows.Count Then
           ' Εκτύπωση τελευταίας σελίδας
           aFooterText = "Τελικό Άθροισμα = "
           toRow = aSheet.UsedRange.Rows.Count
           GoSub PrintJob
       End If
   Else
       ' Εκτύπωση τελευταίας σελίδας
       aFooterText = "Τελικό Άθροισμα = "
       toRow = aSheet.UsedRange.Rows.Count
       GoSub PrintJob
   End If
   
   ' Επαναφορά footer
   aSheet.PageSetup.RightFooter = OldFooter
   
Exit Sub

PrintJob:
   
   aSumBef = aSum
   For i = fromRow To toRow
       ' Έλεγχος μήπως η τιμή είναι κάποιο σύνολο
       If Not aSheet.Cells(i, ColumnToSum).HasFormula Then
           ' Είναι η τιμή νούμερο;
           If Application.IsNumber(aSheet.Cells(i, ColumnToSum)) Then
               aSumCur = aSumCur + aSheet.Cells(i, ColumnToSum).Value
           End If
       End If
   Next i
   aSum = aSum + aSumCur
   fromRow = toRow + 1
   
   aSheet.PageSetup.RightFooter = "Άθροισμα σελίδας = " & Format(aSumCur, "#,##0.00") & vbCr & _
           "Αθροισμα προηγούμενων σελίδων = " & Format(aSumBef, "#,##0.00") & vbCr & _
           aFooterText & Format(aSum, "#,##0.00")
   aSheet.PrintOut j, j
   aSumCur = 0

Return

End Sub

[GEORGE1]

Ευχαριστώ

[UserXP]

Υπήρχε ένα bug στον προηγούμενο κώδικα. Τώρα είναι εντάξει

[GEORGE1]

ok είναι αυτό που ζητούσα, ευχαριστώ πολύ.