Sveučilište u Zagrebu  |  Filozofski fakultet  |  Služba za informatiku  |  Kutak za korisnike  |  Teme


Programsko ostraničavanje Excel tablice

 

Option Explicit

' author: Predrag Gjuro Kladaric (C) 2007
' date: 2007-11-16

' sample procedure, that asks for three lines of white space and a title text
Sub SetPageBreakOnValueChange2()

    SetPageBreakOnValueChange 3, "Department of "
    
End Sub

' SetPageBreakOnValueChange(), the real paging procedure

' description:
' walks the selected area, compares values in the first column of the selected area and,
' when two adjoined values differ, inserts a page break, with optional whitespace before or after
' the newpage, and optional text within the white space

' parameters:
' empty_lines_count parameter inserts appropriate number of empty lines
' negative value for empty_lines_count says: put empty lines after the text and before the newpage
' optional text is put into cell(+2, +2), relative to the split between dissimilar items
' font size for optional text is 20

Sub SetPageBreakOnValueChange(Optional empty_lines_count As Integer = 0, Optional txt As String = "")

    Dim r As Range
    Set r = Selection  ' selection is in the ActiveSheet
    
    Dim first As Boolean
    
    Dim col_number As Integer
    Dim row_number As Integer
    Dim row_start As Integer
    Dim row_count As Integer
    Dim n As Integer
    
    Dim s As String
    Dim s1 As String
    Dim s2 As String
    
    col_number = r.Column
    row_start = r.Rows(1).Row
    row_count = r.Rows.Count
    
    If r.Rows.Count = 1 And r.Columns.Count = 1 Then
        MsgBox "Cell range not selected."
    Else
        Application.ScreenUpdating = False
        Application.Cursor = xlWait
        
        ActiveSheet.ResetAllPageBreaks
        first = True
        For row_number = row_start + row_count - 1 To row_start Step -1
            s = ActiveSheet.Cells(row_number, col_number).Text
            'ActiveSheet.Rows(row_number).PageBreak = xlPageBreakNone
            If first Then
                first = False
                s1 = s
            Else
                s2 = s
                If s1 = s2 Then
                Else
                    For n = 1 To Abs(empty_lines_count)
                        ActiveSheet.Rows(row_number + 1).EntireRow.Insert shift:=xlDown
                    Next
                    If empty_lines_count > 0 Then
                        ActiveSheet.Rows(row_number + 1).PageBreak = xlPageBreakManual
                    Else
                        ActiveSheet.Rows(row_number + 1 + Abs(empty_lines_count)).PageBreak = xlPageBreakManual
                    End If
                    
                    ActiveSheet.Cells(row_number - 1 + Abs(empty_lines_count), 2) = txt & " : " & s1
                    ActiveSheet.Cells(row_number - 1 + Abs(empty_lines_count), 2).Font.Size = 20
                End If
                s1 = s2
            End If
        Next
        For n = 1 To Abs(empty_lines_count)
            ActiveSheet.Rows(row_start).EntireRow.Insert shift:=xlDown
        Next
        ActiveSheet.Cells(row_start - 2 + Abs(empty_lines_count), 2) = txt & " : " & s1
        ActiveSheet.Cells(row_start - 2 + Abs(empty_lines_count), 2).Font.Size = 20
    End If

    Application.Cursor = xlDefault
    Application.ScreenUpdating = True

End Sub
komentare molim ovdje