Страницы: 1
RSS
Макрос сохранения отдельных листов в общем файле формата PDF, Работа с VBA
 
Друзья, помогите пожалуйста!! Подскажите макрос для кнопки activex, чтобы при нажатии отдельные листы, например лист1 и лист3, сохранялись в одном файле pdf. Сохранение файла желательно в текущем месте файла xlsm и с аналогичным названием.

Версия excel и vba 2010
 
Обратите внимание на комментарий в макросе, в нем указано, как Вы можете указать листы, которые нужно сохранить в PDF.
Не забывайте, что этот макрос сохраняет PDF файл в папку с файлом, откуда запускается макрос. Если Вы будете запускать макрос из личной книги макросов, то файл будет создаваться там же, где личная книга макросов.
Код
Sub Создать_PDF()
    Dim arrSelSheets(), i As Long
    Application.ScreenUpdating = False 

    ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
    For i = 1 To UBound(arrSelSheets)
        arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
    Next
    
    'здесь укажите, какие листы нужно сохранить в PDF
    Worksheets(Array("Лист1", "Лист3")).Select
        
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ThisWorkbook.Path & "\" & "PDF файл.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
    Worksheets(arrSelSheets).Select

    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation
End Sub
 
Все перепечатываю букву в букву, а выдаёт run time error 1004 :(
Изменено: deftone - 07.11.2016 21:19:11
 
А в сообщении с ошибкой какой текст?
Пока предположу, что Вы вставили макрос в файл, который не сохранен, и "ThisWorkbook.Path" возвращает пустую строку, что приводит к ошибке.
Изменено: Karataev - 06.11.2016 23:20:40
 
Файл сохраненный. Вот что выдаёт:
 
Цитата
deftone написал: Все перепечатываю букву в букву
попробуйте не перепечатывать, а скопируйте код из поста в VBE и только замените имена листов, а остальное не меняйте, посмотрите, останется ли ошибка
 
Да, Это помогло. Спасибо!
Просто интересно почему ошибка была?
 
А в какой строке кода была ошибка?
 
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       ThisWorkbook.Path & "\" & "PDF файл.pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
 
Нужно посмотреть, как Вы перепечатывали. Не могу сказать, почему была ошибка.
 
Как еще можно усовершенствовать код?
Например, чтобы имя файла PDF автоматически собиралось из данных в нескольких ячейках; чтобы при сохранении не происходило наложение на имеющийся файл, а выполнялось сохранение новой копии или выводился запрос "сохранить имеющийся или создать копию?"; чтобы при открытом файле PDF не возникало системной ошибки, а выводилось предупреждение "Для сохранения завершите работу с открытым файлом PDF!".
Еще после сохранения у меня остаются выделенные листы, что блокирует работу с кнопками ActiveX на листе. Каким кодом можно отменить выделение 2-х листов?
 
в данном макросе есть недостаток. Если один файл с указанным именем уже создан, то во второй раз выдает ошибку, пока файл не переименуешь или не уберешь из папки
 
С чего это вдруг 'недостаток'? По условию задачи этого не требовадось
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
С чего это вдруг 'недостаток'? По условию задачи этого не требовадось
Я имела ввиду, что лучше сделать, чтобы можно было сохранять более одного раза без лишних действий)

Sub SafeAsPdf()
   Dim arrSelSheets(), i As Long
   Application.ScreenUpdating = False

   ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
   For i = 1 To UBound(arrSelSheets)
       arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
   Next
 
   Worksheets(Array("КП")).Select
       
   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       ThisWorkbook.Path & "\" & "КП " & Format(Now, "YYYYMMDD") & " " & Format(Now, "hhmm") & ".pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
       
   Worksheets(arrSelSheets).Select

   Application.ScreenUpdating = True
   MsgBox "Урррааа!", vbInformation
End Sub
 
Код
Sub SafeAsPdf()
   Dim arrSelSheets(), i As Long
   Application.ScreenUpdating = False

   ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
   For i = 1 To UBound(arrSelSheets)
       arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
   Next
  
   Worksheets(Array("КП")).Select
        
   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       ThisWorkbook.Path & "\" & "КП " & Format(Now, "YYYYMMDD") & " " & Format(Now, "hhmm") & ".pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
   Worksheets(arrSelSheets).Select

   Application.ScreenUpdating = True
   MsgBox "Урррааа!", vbInformation
End Sub
может кто дописать код. Чтобы имя файла сохранялась согласно указаной ячейки в книги.  
Изменено: Мелко - 22.11.2019 22:20:12
 
Мелко, код следует оформлять соответствующим тегом: ищите такую кнопку (см. скрин) и исправьте своё сообщение.
По вопросу: такое спрашивают довольно часто. Запрос в поиск по форуму, например, так: взять имя файла из ячейки
 
Код
Sub SafeAsPdf()
   Dim arrSelSheets(), i As Long
   Application.ScreenUpdating = False

   ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
   For i = 1 To UBound(arrSelSheets)
       arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
   Next
  
   Worksheets(Array("Лист")).Select
        
   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       ThisWorkbook.Path & "\" & Range("A1") & Format(Now, "YYYYMMDD") & " " & Format(Now, "hhmm") & ".pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
   Worksheets(arrSelSheets).Select

   Application.ScreenUpdating = True
   MsgBox "Урррааа!", vbInformation
End Sub
Спасибо!
Изменено: Мелко - 22.11.2019 22:32:28
 
Доброго времени суток! Подскажите. пожалуйста, по какой причине возникает ошибка "Run time error '9'?
Код
Sub SafeAsPdf()
   Dim arrSelSheets(), i As Long
   Application.ScreenUpdating = False
 
   ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
   For i = 1 To UBound(arrSelSheets)
       arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
   Next
   
   Worksheets(Array("Shablon_AOSR_List")).Select
         
   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       ThisWorkbook.Path & "\" & "Shablon_AOSR_List" & Format(Now, "YYYYMMDD") & " " & Format(Now, "hhmm") & ".pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         
   Worksheets(arrSelSheets).Select
 
   Application.ScreenUpdating = True
   MsgBox "ура!", vbInformation
End Sub
 
а вот такой вопрос, что добавить в макрос, что бы получилось условие для печати: при значении ячейки =0 сохраняем 3 листа, а при значении =1, сохраняем 4 листа?
 
Блок If. Или Select Case.
 
RAN, подскажите куда подставить то. Я туповат в макросах, только разбираться начал.
я так понимаю эта строчка
Код
If Sheet1.Range("A1").Value = 0 Then
должна стать перед
Код
'здесь укажите, какие листы нужно сохранить в PDF    
Worksheets(Array("Лист1", "Лист3")).Select
 
Karataev, Странно, у меня почему-то один из листов дважды печатается
 
А как можно сделать, чтобы при нажатии на кнопку, вышла строка ввода, в которой можно задать диапазон сохраняемых листов? Например есть 30 листов, мне нужно сохранить с 1-20,нужно именно чтобы диапазон вводился через строку ввода, а не в коде
 
Код
Application.Dialogs(xlDialogPrint).Show
 
МатросНаЗебре, здравствуйте. А можно пожалуйста поподробнее, я не очень силен, только учусь
 
МатросНаЗебре, я разобрался, но к сожалению это не совсем, то что мне нужно. Нужно чтобы при нажатии на кнопку, вышла строка input, а в ней введены все листы из моего файла, например так: п1,п2,п3,п4,п5,п6,п7,п8,п9,п10,п11,п12. Мне из них необходимо сохранить в PDF п1,п2,п3,п4 для этого нужно стереть лишние и подтвердить кнопкой ОК.
Изменено: Александр А - 27.12.2022 12:13:03
 
Код
Sub PrintPdfViaInputbox()
    Dim arr As Variant
    ReDim arr(1 To ActiveWorkbook.Worksheets.Count)
    Dim sh As Worksheet
    Dim yy As Long
    For Each sh In ActiveWorkbook.Worksheets
        yy = yy + 1
        arr(yy) = sh.Name
    Next
    Dim ss As String
    ss = Join(arr, ",")
    ss = InputBox("Выберите листы", "Печать", ss)
    
    arr = Split(ss, ",")
    Dim vv As Variant
    For Each vv In arr
        Set sh = Nothing
        On Error Resume Next
        Set sh = Sheets(vv)
        On Error GoTo 0
        If Not sh Is Nothing Then
            
            sh.Select
            SafeAsPdf
            
        End If
    Next
End Sub
 
МатросНаЗебре, ругается
Изменено: Александр А - 27.12.2022 12:31:40
 
Предполагалось, что есть какой-то макрос, который уже умеет работать с активным листом, например, SafeAsPdf.
Страницы: 1
Наверх