Страницы: 1
RSS
Печать колонтитулов через VBA
 
Доброго времени суток, уважаемые форумчане. Подскажите, пожалуйста, ответ на небольшой вопрос. Итак, ситуация: необходимо в колонтитул листа вывести информацию (сумму по странице) . Для теста (код выведен на кнопку) я попытался сделать это так:
Код
    Dim HPB As HPageBreak, rngHPB As Range, sum_page As Double, i As Long, j As Long
        If ActiveSheet.Name = "Остатки на складе" Then 'обязательно условие - указание имени листа, иначе VBA пытается выполнить код на др. листах
            With Sheets("Остатки на складе")
'                If .HPageBreaks.Count > 0 Then
                    Set rngHPB = .HPageBreaks(.HPageBreaks.Count).Location
                    i = 8
                    
                    For Each HPB In ActiveSheet.HPageBreaks
                        j = j + 1
                        Set rngHPB = HPB.Location
                        sum_page = Application.Sum(.Range(.Cells(i, 9), .Cells(HPB.Location.Row - 1, 9)))
                        If sum_page > 0 Then
                            i = HPB.Location.Row
                            .PageSetup.RightFooter = Join(Array("Итого по стр. ", j, Space(1), Format(sum_page, "0.00")))
                            .PrintOut From:=j, To:=j, Copies:=1, Collate:=True
                        Else: Exit Sub
                        End If
                    Next HPB
'                End If
            End With
        End If
Может и не совсем оптимально придумал (критика и оптимизация кода приветствуются ;) ), но код работает. НО когда я попытался перенести его в событие Workbook_BeforePrint(Cancel As Boolean), то ничего не вышло, точнее вышло да не так: печатаются все 19 из требуемых (в данном примере) 4 страниц и сумма в колонтитулах ставится одинаковая для всех страниц (по 4 странице). Почему так получается и что надо изменить в коде, чтобы исправить эту ошибку?
Заранее спасибо всем откликнувшимся
 
мне кажется нельзя задать каждому листу разные колонтитулы (вроде можно создать только для 1-го листа и для всех остальных, но вам тоже не подойдёт, наверное)
 
Здравствуйте.
У меня нет принтера, но когда я отправляю на печать и сохраняю в формате .XPS сохраняется правильно. Можно попробовать перед отправкой на печать задавать область печати листа отправляемого на печать. Тогда на принтер всегда будет отправляться только один лист с колонтитулами которые туда вставятся для этого листа. Или попробовать складывать эти файлы в формате .XPS в определенную папку с номерами файлов, отправлять все файлы на печать, а после удалить эту папку. Других идей пока нет. Может кто знает какой вариант и подскажет как это сделать.
Наверно лучше выводить на печать только диапазон нужного листа и так последовательно по каждому листу отдельно.
У меня получилось так:
Код
Private Sub CommandButton2_Click()
    Dim HPB As HPageBreak, rngHPB As Range, sum_page As Double, i As Long, j As Long, nl As Long, kl As Long
    Application.ScreenUpdating = False
        If ActiveSheet.Name = "Остатки на складе" Then 'обязательно условие - указание имени листа, иначе VBA пытается выполнить код на др. листах
            With Sheets("Остатки на складе")
'                If .HPageBreaks.Count > 0 Then
                    Set rngHPB = .HPageBreaks(.HPageBreaks.Count).Location
                    i = 8
                    For Each HPB In ActiveSheet.HPageBreaks
                        j = j + 1
                        Set rngHPB = HPB.Location
                        sum_page = Application.Sum(.Range(.Cells(i, 9), .Cells(HPB.Location.Row - 1, 9)))
                        If sum_page > 0 Then
                            If j = 1 Then
                                nl = 1
                            Else
                                nl = i
                            End If
                            i = HPB.Location.Row
                            kl = i - 1
                            .PageSetup.RightFooter = Join(Array("Итого по стр. ", j, Space(1), Format(sum_page, "0.00")))
                            .Range("A" & nl & ":J" & kl).PrintOut Copies:=1
                        Else: Exit Sub
                        End If
                    Next HPB
'                End If
            End With
        End If
    Application.ScreenUpdating = True
End Sub


Изменено: gling - 08.04.2021 22:21:18
Страницы: 1
Наверх