Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1 2 След.
RSS
Формирование диапазона ячеек для печати, скрываю строки, но страницы печатаются
 
Доброй ночи.
Помогите, пожалуйста!

Ситуация.
Динамическим образом формирую однотипные отчёты об исследованиях. А именно, в цикле заполняю расчётную форму данными из БД, на ее основании считается и формируется на отдельном листе отчёт (точнее, его красиво отформатированный шаблон с размеченными областями печати). Далее (в том же цикле) страница сохраняется в pdf-формате на диск (без открытия) и т.д.
В зависимости от результатов расчётов, некоторые части отчёта остаются не заполненными (в т.ч. графики). Это довольно значительные по размерам диапазоны (100-200 строк). Их не нужно включать в итоговый pdf-файл, так как суммарно таких пустых диапазонов может быть до 10 страниц в документе, состоящем всего из 40 страниц (к примеру)...

Проблема.
Для решения задачи в непечатной области выделил служебную колонку.
В каждой ячейке колонки расчитываю значение (0 или 1), указывающее мне, нужна ли данная строка в итоговом отчёте.
Перед печатью в pdf-файл скрываю все строки со значением "0" в ячейке этой служебной колонки.
Весь ненужный контент в итоге не печатается в pdf-файл (так и задумано).
НО всё-таки пустые страницы в том же ненужном количестве в файле создаются.

Вопросы.
Можно ли подкорректировать избранный мною способ для печати только полезного контента без пустых страниц?
Возможно посоветуете другой механизм решения?

Спасибо!
 
UsAlex, У меня Office 2013... После сохранения в PDF штатным способом, лишних листов не выходит. Все что скрыто - то скрыто. У Вас, возможно, установлены разрывы страниц, которые не снимаются (или не перещитываются после программного скрытия строк). Но гадать сложно, ведь
Цитата
[НО всё-таки пустые страницы в том же ненужном количестве в файле создаются.
не очень понятно для восприятия... :(  А файлика нет 8-0 ...
 
AAF, да, разрывы страниц есть -- страхуюсь от хаоса при динамическом формировании. Надеялся (по-видимому, зря), что если у меня строки скрываются целыми страницами подряд -- то и страниц не будет.

ОК, может быть пример программного пересчитывания разрывов страниц посоветуете? Не думаю, правда, что я готов алгоритмизировать это на примере своего отчёта(
Код простой:
Код
        For row_Visible = 1 To 1638
            If Worksheets("Report").Cells(row_Visible, 31).Value = 1 Then
                Worksheets("Report").Rows(row_Visible).Hidden = False
            Else
                Worksheets("Report").Rows(row_Visible).Hidden = True
            End If
        Next row_Visible
        
        For row_Visible = 1639 To 2082
            If Worksheets("Report").Cells(row_Visible, 31).Value = 0 Then
                Worksheets("Report").Rows(row_Visible).Hidden = True
            Else
                Worksheets("Report").Rows(row_Visible).Hidden = False
                Worksheets("Report").Rows(row_Visible).EntireRow.AutoFit 'установка нормальной высоты строк
            End If
        Next row_Visible
Кстати, "установка нормальной высоты строк" не работает. Не стал бы тревожить но раз уже к коду подошли -- может подскажите почему (Ексель-2010).
 
UsAlex, Сложно без файла сказать...
Цитата
UsAlex написал:
Кстати, "установка нормальной высоты строк" не работает. Не стал бы тревожить но раз уже к коду подошли -- может подскажите почему (Ексель-2010).
А с файлом скажу!  ;)  Проблемки с форматами, а может объединение ячеек (не дай бог)... Гадать можно бесконечно...
И по разрывам страниц тоже, но философию формирования отчета надо видеть.
И строки по одной скрывать/отображать программно тормознуто весьма выходит, наверно, да?
Вы хотя бы на три листа выложите Ваш продукт, а то у нас дальше размышлений у парадного подъезда не пойдет.
 
UsAlex, Просто, поймите, отчет это визуальное представление данных. Как кто его делает одному автору известно. Какими программными приемами и т. д.....
 
Вариант отчёта с уже скрытыми строками. Для наглядности форматирования. Связи разорваны, обновляться не должно.

Почему-то здесь не открывается диалог для загрузки файла. Ссылка -- http://fex.net/956304834226
 
Процедура генерирования отчётов
Код
Public Sub Reports_Export()
    Dim i As Integer
    Dim j As Integer
    Dim row_Visible As Long
    Dim Flag_in_BD As Boolean
    Dim objShellApp As Object, objFolder As Object, ulFlags
    Dim avFolder As String
    Dim NameE As String
    
    ' папка для отчётов
    Set objShellApp = CreateObject("Shell.Application")
    ulFlags = 0
    Set objFolder = objShellApp.BrowseForFolder(0, "Выбрать папку для сохранения отчётов", ulFlags, "C:\Documents and Settings\user\360\") '"
    avFolder = objFolder.Self.Path
    If Err.Number <> 0 Then MsgBox "Папка не выбрана!"

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' В цикле:
    '  Проверяем, есть ли в БД оценки сотрудника
    For i = 1 To 46
        Flag_in_BD = False
        For j = 1 To Worksheets("БД").Cells(1, 19).Value
            If Worksheets("БД").Cells(j, 6).Value = i Then
                NameE = Worksheets("ÁÄ").Cells(j, .Value
                Flag_in_BD = True
                Exit For
            End If
        Next j

        '   Устанавливаем вводные, всё пересчитываем
        If Flag_in_BD Then
           Worksheets("Calc").Cells(1, 2).Value = i
           Worksheets("Calc").Cells(1, 3).Value = NameE
           Worksheets("Report").Cells(17, 15).Value = NameE
           Worksheets("Report").PageSetup.RightHeader = NameE
            
           Worksheets("Calc").Calculate
           Call Comp_Sort
           Call Q_Sort
           Call Diff_Sort
           Call Get_Comments
            
           Worksheets("Report").Calculate
 
        
           '   Скрываем лишние части отчёта
           For row_Visible = 1 To 1638
              If Worksheets("Report").Cells(row_Visible, 31).Value = 1 Then
                 Worksheets("Report").Rows(row_Visible).Hidden = False
              Else
                 Worksheets("Report").Rows(row_Visible).Hidden = True
              End If
           Next row_Visible
        
           For row_Visible = 1639 To 2082
              If Worksheets("Report").Cells(row_Visible, 31).Value = 0 Then
                 Worksheets("Report").Rows(row_Visible).Hidden = True
              Else
                 Worksheets("Report").Rows(row_Visible).Hidden = False
                 Worksheets("Report").Rows(row_Visible).EntireRow.AutoFit 'Установка нормальной высоты строки
              End If
           Next row_Visible
        
    
           ' рабочий код заливки в пдф
           Worksheets("Report").ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
           avFolder & "\" & NameE & ".pdf", Quality:= _
           xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
           OpenAfterPublish:=False
        End If
    Next i
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Изменено: UsAlex - 28 Фев 2017 14:01:07
 
Где-то так, кажется...
Код
Sub СкрытьЛишнее()
With Worksheets("Report")
  .ResetAllPageBreaks
  idxVis = 1
  rStart = 1
  For row_Visible = 2 To 1638
    If idxVis = 1 And .Cells(row_Visible, 32) = 1 Then _
      .HPageBreaks.Add Before:=Rows(row_Visible)
    If idxVis <> .Cells(row_Visible, 31).Value Then
      idxVis = Abs(idxVis - 1)
      .Rows(rStart & ":" & row_Visible - 1).Hidden = idxVis
      rStart = row_Visible
    End If
  Next row_Visible
  rStart = 1639
  For row_Visible = 1639 To .UsedRange.Row + .UsedRange.Rows.Count
    If idxVis = 1 And .Cells(row_Visible, 32) = 1 Then _
      .HPageBreaks.Add Before:=Rows(row_Visible)
    If idxVis <> .Cells(row_Visible, 31).Value Then
      If idxVis = 1 Then .Rows(rStart & ":" & row_Visible - 1).EntireRow.AutoFit
      idxVis = Abs(idxVis - 1)
      .Rows(rStart & ":" & row_Visible - 1).Hidden = idxVis
      rStart = row_Visible
    End If
  Next row_Visible
End With
End Sub

Код
Sub ПоказатьВсе()
With Worksheets("Report")
  .Rows(1 & ":" & .UsedRange.Row + .UsedRange.Rows.Count).Hidden = 0
  .Rows(1639 & ":" & .UsedRange.Row + .UsedRange.Rows.Count).EntireRow.AutoFit
End With
End Sub

В столбце "AF" надо проставить "1" в строках, над которыми будут ручные (фиксированные) разрывы страниц.
Если разрывы страниц установлены верно, то пометку можно сделать макросом:
Код
Sub ПометкаРучныхРазрывовСтраниц()
With ActiveSheet
  Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1).Select
  For i = 1 To .HPageBreaks.Count
    If .HPageBreaks(i).Type = xlPageBreakManual Then .Cells(.HPageBreaks(i).Location.Row, 32) = 1
  Next
End With
End Sub
Изменено: AAF - 28 Фев 2017 08:06:20
 
UsAlex, код следует оформлять соответствующим тегом. Посмотрите, как он выглядит у других. Ищите такую кнопку и исправьте свои сообщения.
Тег VBA.jpg (19.2 КБ)
 
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=profile_view&UID=76600
AAF, огромное спасибо! Просто огромнейшее!

Код корректировал -- в 32-ой колонке использую формулы, всё выстраивается, Вы меня спасли.
Может подскажете ещё, как сделать "железобетонный" разрыв страницы -- в одном частном случае "1" в 32-ой не срабатывает (попадает в верх страницы, видимо, я, честно, с механикой Вашего кода ещё не имел времени разобраться).

EntireRow.AutoFit не работает всё-равно, но на фоне решения главной проблемы -- это мелочь. Закомментил эту строку, выставил вручную высоту строк побольше, не очень красиво но очень эффективно))

Ещё раз спасибо!
 
UsAlex,
Цитата
UsAlex написал:
Код корректировал -- в 32-ой колонке использую формулы
Исправьте '32" на "33", например, и используйте ее. Над той строкой, в которой стоит "1" и будет формироваться разрыв страницы.
Цитата
UsAlex написал:
попадает в верх страницы
Каждой или какой?
Цитата
UsAlex написал:
EntireRow.AutoFit не работает всё-равно
Номера строк в студию...  :D  Ведь Вы присылали пример и его можно обсуждать  ;)
 
п.1: ну, так в том и вкус, что я в ряде случаев (не всегда) "1"/"0" в 32-ой столбец подставляю чётко понимая при каждой генерации что мне надо в отчёт. Потому что иначе, в изначальном варианте работало не так как надо.
п.2: у меня конкретно строка 639 ("3. Профиль способностей") не слушается, залезает на пред.страницу.
п.3: всё, что ниже строки 1638, -- туда комментарии подтягиваются и их бывает до 20 строк в ячейке)))
Изменено: UsAlex - 28 Фев 2017 16:30:52
 
Цитата
UsAlex написал:
в 32-ой столбец подставляю чётко понимая при каждой генерации что мне надо в отчёт
Имеется ввиду разрыв?
 
Да. Потому что в случае принудительного расставления "1" подряд могут идти страницы, заполненные на 40-50%.
И да, потому что даже в случае явного указания разрыва страницы (как в случае с "3. Профиль способностей") этот разрыв не появляется. Повторюсь, не изучил алгоритм, пока только воспользовался(
 
UsAlex, Может быть сделать возможность установки предполагаемых разрывов страниц, типа, если рвать, то только в указанных местах, т. е. если не влезло, то рвем по ближайшему последнему встретившемуся рекомендуемому разрыву?
Имеется ввиду, что рекомендуемый разрыв не будет применяться, если все что до следуюющего влезает на ту же страницу.
Кроме того можно оставить жесткие разрывы, которые будут выполняться всегда, независимо от ситуации.
Изменено: AAF - 28 Фев 2017 17:20:08
 
Да, спасибо, поэкспериментирую)

Вот как выглядит то, что плохо выглядит (там со скринами отчёта) -- http://fex.net/#!829711743885

А вот код но уже не прошу думать над правками -- только для Вашего любопытства)
Спасибо большое!!
Код
Public Sub Reports_Export()
    Dim i As Integer
    Dim j As Integer
    Dim Flag_in_BD As Boolean
    Dim objShellApp As Object, objFolder As Object, ulFlags
    Dim avFolder As String
    Dim NameE As String
' переменные для разбиения страниц
    Dim idxVis As Integer
    Dim rStart As Integer
    Dim row_Visible As Long

    
    ' Устанавливаем папку для отчётов
    Set objShellApp = CreateObject("Shell.Application")
    ulFlags = 0
    Set objFolder = objShellApp.BrowseForFolder(0, "Выбрать папку для сохранения отчётов:", ulFlags, "C:\Documents and Settings\user\360\") '"
    avFolder = objFolder.Self.Path
    If Err.Number <> 0 Then MsgBox "Папка не выбрана!"

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' В цикле:
    '   Проверяем есть ли в БД оценки сотрудника
    For i = 1 To 180
        Flag_in_BD = False
        For j = 1 To Worksheets("БД").Cells(1, 19).Value
            If Worksheets("БД").Cells(j, 6).Value = i Then
                NameE = Worksheets("БД").Cells(j, 8).Value
                Flag_in_BD = True
                Exit For
            End If
        Next j

        '   Устанавливаем вводные. Пересчитываем всё.
        If Flag_in_BD Then
            Worksheets("Calc").Cells(1, 2).Value = i
            Worksheets("Calc").Cells(1, 3).Value = NameE
            Worksheets("Report").Cells(17, 15).Value = NameE
            Worksheets("Report").PageSetup.RightHeader = NameE
            
            Worksheets("Calc").Calculate
            Call Comp_Sort
            Call Q_Sort
            Call Diff_Sort
            Call Get_Comments
            
            Worksheets("Report").Calculate
        
             With Worksheets("Report")
                .ResetAllPageBreaks
                idxVis = 1
                rStart = 1
  
                For row_Visible = 2 To 1628
                    If idxVis = 1 And .Cells(row_Visible, 32) = 1 Then _
                        .HPageBreaks.Add Before:=Rows(row_Visible)
                        If idxVis <> .Cells(row_Visible, 31).Value Then
                        idxVis = Abs(idxVis - 1)
                        .Rows(rStart & ":" & row_Visible - 1).Hidden = idxVis
                        rStart = row_Visible
                    End If
                Next row_Visible
  
                rStart = 1629
                For row_Visible = 1629 To .UsedRange.Row + .UsedRange.Rows.Count
                    If idxVis = 1 And .Cells(row_Visible, 32) = 1 Then _
                    .HPageBreaks.Add Before:=Rows(row_Visible)
                
                    If idxVis <> .Cells(row_Visible, 31).Value Then
'                       If idxVis = 1 Then .Rows(rStart & ":" & row_Visible - 1).EntireRow.AutoFit
                        idxVis = Abs(idxVis - 1)
                        .Rows(rStart & ":" & row_Visible - 1).Hidden = idxVis
                        rStart = row_Visible
                    End If
                Next row_Visible
            End With
    
            Worksheets("Report").ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            avFolder & "\" & NameE & ".pdf", Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        
        End If
    Next i
    
    Application.Calculation = xlCalculationAutomatic
    Application.Visible = True
    Application.ScreenUpdating = True
End Sub
Изменено: UsAlex - 28 Фев 2017 17:29:53
 
UsAlex,
Цитата
UsAlex написал:
А вот код но уже не прошу думать над правками -- только для Вашего любопытства)
Скину позже вечером другой код, ведь код зависит только от поставленной задачи  :D
 
Спасибо за отзывчивость)!
 
UsAlex, Приколот файлик с возможностью установки срытия/отображения строк и рекомендуемых/обязательных разрывов страниц
С автофитом отдельный вопрос, но у меня аврал до 8 марта, поэтому вопросы принимаются, но отвечаются после 8-го, скорее всего.
Если по выложенному сейчас, то отвечу сразу....
Код
Sub HideProc()
Dim shNm, i As Integer, r As Long, rVis As Long, rBrk As Long, rStart As Long
shNm = "Лист1"
'столбец 33 - 0/1, скрыть/отобразить
'столбец 34 - -1/1, рекомендуемый/обязательный разрыв
'столбец 36 - "SoftBreak"/"HardBreak", рекомендуемый/обязательный разрыв
'столбец 36 - применяется для иллюстрации. Все с комментом "для иллюстрации" можно удалить
With Worksheets(shNm)
  .Columns(36).ClearContents 'очистка столбца иллюстрации
  r = 2
  rVis = 1
  rStart = 1
  Do Until r >= .UsedRange.Row + .UsedRange.Rows.Count 'Скрываем/отображаем согласно значению 0/1 в столбце 33
    If rVis <> .Cells(r, 33) Then 'значит смена диапазона
      rVis = Abs(rVis - 1)
      .Rows(rStart & ":" & r - 1).Hidden = rVis 'примняем .Hidden к пройденному диапазону
      rStart = r 'начало следующего диапазона
    End If
    r = r + 1
  Loop
  .Rows(rStart & ":" & r - 1).Hidden = Abs(rVis - 1) 'обработка последнего пройденного диапазона на листе
  r = 1 'установка r для нового пробега по листу
  .ResetAllPageBreaks 'сброс всех ручных разрывов (.HPageBreaks(i).Type = xlPageBreakManual)
  .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1).Select 'технический костыль для безошибочного выполнения следующего цикла
  '"https://support.microsoft.com/ru-ru/help/210663/you-receive-a-subscript-out-of-range-error-message-when-you-use-hpagebreaks-or-vpagebreaks.location-in-excel"
  Do 'бежим по разрывам страниц
    i = i + 1
    Do
      If Not .Rows(r).Hidden Then 'если не скрыта
        If .Cells(r, 34) = 1 Then 'если нужен хардовый разрыв
          .HPageBreaks.Add Before:=Rows(r)
          .Cells(.HPageBreaks(i).Location.Row, 36) = "HardBreak" 'для иллюстрации, можно удалить
        Else
          If .Cells(r, 34) = -1 Then rBrk = r 'если нужен рекомендуемый разрыв
        End If
      End If
      r = r + 1
    Loop Until r > .HPageBreaks(i).Location.Row 'выход если r>строки текущего разрыва i
    If rBrk Then 'если был рекомендован разрыв
      .HPageBreaks.Add Before:=Rows(rBrk) 'применяется рекомендуемый разрыв
      .Cells(.HPageBreaks(i).Location.Row, 36) = "SoftBreak" 'для иллюстрации, можно удалить
      rBrk = 0
    End If
  Loop Until i >= .HPageBreaks.Count
  .Cells(1).Select
End With
End Sub
Изменено: AAF - 1 Мар 2017 14:57:30
 
Спасибо, пользуюсь)! Уверен, инструмент пойдёт в массы)!

Ещё у меня выдаёт ошибку на "костыле". Пробовал предварительно сделать Worksheets(shNm).Select -- уже на этой строке "вылетает"(
Если "костыль закомментировать, ошибка на строке  .Cells(1).Select

Вообщем, закомментировал обе эти строки, код самую малость "ошибается" из-за этого, но в целом всё как надо, спасибо)!!
Код
  .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1).Select 'технический костыль для безошибочного выполнения следующего цикла
 
UsAlex, Лист должен быть активен... По сути я должен был написать не Sheets(shNm), а ActiveSheet, но привычка....
Да, кстати, а какая ошибка, просто интересно?
Да, костыль не нужен, если вручную выделить последнюю ячейку на листе (по сути это костыль и делает), т. е. проблемка с select, а это бывает когда лист не активен...  
Поставьте в начале процедуры Range("A1").Select для проверочки  :D
Изменено: AAF - 1 Мар 2017 22:12:34
 
http://fex.net/#!044659834375 -- скрины ошибки, ексель вылетает.

Run-time error '-2147417848 (80010108)':
Method 'Select' of object '_Worksheet' failed
 
Код
Sub HideProc()
Dim shNm, i As Integer, r As Long, rVis As Long, rBrk As Long, rStart As Long
shNm = "Имя Вашего листа"
With Worksheets(shNm)
  Worksheets(shNm).Activate
    .Range("A1").Select
'    остальное как было после With Worksheets(shNm)

End Sub
Изменено: AAF - 2 Мар 2017 14:06:10
 
На Activate вылетает Excel.
Если Activate не использовать, на Select вылетает только дебаггер, ошибка неверное применение метода Select к объекту Range, как то так...
 
UsAlex, а на другом компе?
Да, и это именно мой файл?
Например,
Код
Sub ActivateTest()
  Sheets(1).Activate
End Sub

должен работать в любом файле, иначе, либо с Excel проблемка, либо существует некий процесс, который может мешать...
Изменено: AAF - 2 Мар 2017 18:14:15
 
Проблема не в Вашем файле, -- это у меня не пойми что, видимо) Займусь отладкой-поиском) Вам спасибо)!
 
UsAlex, Отпишитесь, просто интересно как решилось...
И еще столбец 35 зарезервирован под автофит... Там придется писать что-то искусственное, т. к. Excel не отработает такие форматирования под автофит...
 
Я неработающий "автофит" обошёл следующим образом.
Напомню: у меня проблемные строки формируются путём переноса из из другой таблицы текстов неизвестной длины. Но физически эти тексты размещаются в одной (первой) ячейке каждой строки.
Решение:
В служебной колонке изучаю, что именно находится в первой ячейке: количество абзацев (СИМВОЛ(10)), количество символов последнего абзаца (у меня примерно 100 символов помещается в одной строке в ячейке, -- делю, округляю). И формирую с запасом на 1 количество строк в ячейке в виде значения ячейки. Тут алгоритм можно сколь-угодно изощрённый реализовать одной формулой.
А при выполнении процедуры подготовки к печати перебираю все эти строки и устанавливаю им высоту 13*служебную колонку условной высоты в строках.
Торможений особых нет, хотя на этом форуме упоминается и более продуктивный способ: загрузить вектор_высот_строк в массив и обработать весь Range.

По Activate-Select пока не сделал но еще буду искать.
Изменено: UsAlex - 3 Мар 2017 12:54:45
 
Заработал Sheets.Active, разрывы по-прежнему не всегда работают, продолжаю отладку)
 
UsAlex, если вот это работает,
Код
Sub ActivateTest()
  Sheets(1).Activate
  Range("ЛюбойАдрес").Select
End Sub

то разрывы должны работать таким образом:
1 - в любом случае разрыв, где единица - первая строка на новой странице
и
-1 - если не влезает на страницу до следующего любого разрыва, тогда -1 - первая строка на новой странице
Страницы: 1 2 След.
Читают тему (гостей: 1)