Выборочное сохранение листов в pdf

Дата: Четверг, 13.10.2022, 14:16 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Всем привет! Кросс
Да, я знаю, что тема на форуме поднималась не первый десяток раз, но все же столкнулся вот с какими нюансами:
В копилке есть вот такой макрос:
[vba]

Код

Private Sub CommandButton1_Click()
Dim strFileName As String
s = Sheets("Данные").Range("N1").Value
a = Split(s, ",")
For i = 0 To UBound(a) 'начало цикла по массиву а с шагом по умолчанию 1
a(i) = Sheets(Val(a(i))).Name 'действия для каждой итерации цикла
Next 'переход на следующую итерацию циклаSheets(a).Select
Sheets(a).Select
    strFileName = "Бланк обмера " & Sheets("Данные").Range("L1").Value
    On Error Resume Next
    ChDir "\"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ActiveWorkbook.Path & "\" & strFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
End Sub

Sub d()
    strFileName = "Бланк обмера " & Sheets("Данные").Range("L1").Value
    On Error Resume Next
    ChDir "\"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ActiveWorkbook.Path & "\" & strFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
End Sub

[/vba]
, работа которого меня полностью устраивает но:
- после выполнения макроса листы отправленные в pdf остаются активными, т.е. выделенными.
- попытался присвоить имя из ячеек, находящихся на другом листе:
[vba]

Код

strFileName = "Бланк обмера " & Sheets("Бланк_обмера").Range("L1") & Sheets("Бланк_обмера").Range("V1") & Sheets("Бланк_обмера").Range("M2") & Sheets("Бланк_обмера").Range("W4").Value

[/vba]
макрос срабатывает, но файл не создается и соответственно его нельзя увидеть.
- pdf файл автоматически создается в папке, в которой находится исходный файл, а мне необходимо, чтобы созданные файлы помещались в определенную папку, например: Диск D - Смета - Обмеры.
Возможно ли данный макрос подправить с учетом изложенных выше предпочтений?
Спасибо.

Код

СообщениеВсем привет! Кросс
Да, я знаю, что тема на форуме поднималась не первый десяток раз, но все же столкнулся вот с какими нюансами:
В копилке есть вот такой макрос:
[vba]

Код

Автор - graffserg
Дата добавления - 13.10.2022 в 14:16

Дата: Четверг, 13.10.2022, 14:24 | Сообщение № 2

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16674

Репутация: 6479 ±

Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS

1. выделите один лист селектом
2. сцепили вы "Бланк обмера " с L1 V1 M2 и W4 и что получили в итоге?
3. замените ActiveWorkbook.Path на нужный путь

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Дата: Четверг, 13.10.2022, 14:35 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Цитата _Boroda_, 13.10.2022 в 14:24, в сообщении № 2 (

)

1. выделите один лист селектом

Это я знаю, вопрос в другом - как сделать, чтобы выделение листов автоматически снималось после выполнения макроса.

Цитата _Boroda_, 13.10.2022 в 14:24, в сообщении № 2 (

)

2. сцепили вы "Бланк обмера " с L1 V1 M2 и W4 и что получили в итоге?

Макрос срабатывает, но:
- pdf файл не создается.

Цитата _Boroda_, 13.10.2022 в 14:24, в сообщении № 2 (

)

3. замените ActiveWorkbook.Path на нужный путь

Попробую.
Спасибо.

Дата: Четверг, 13.10.2022, 15:10 | Сообщение № 4

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16674

Репутация: 6479 ±

Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS

Цитата graffserg, 13.10.2022 в 14:35, в сообщении № 3 (

)

как сделать, чтобы выделение листов автоматически снималось

Ну один-то должен остаться? Вот и выделите его в конце макроса. С остальных выделение снимется
2. Я разве про срабатывание макроса спрашивал?

Дата: Четверг, 13.10.2022, 15:50 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Вот, попробовал функцией:

Код

=СЦЕПИТЬ(ТЕКСТ(Бланк_обмера!W4;"ДД.ММ.ГГГГ");" ";Бланк_обмера!L1;" ";Бланк_обмера!V1;" ";Бланк_обмера!M2)

сцепить название.
В макросе подправил строку:
[vba]

Код

strFileName = Sheets("Данные").Range("L1").Value

[/vba]
Нажимаю кнопку - появляется окно "Идет процесс публикации", потом перебрасывает на 1 лист книги excel и все на этом заканчивается.
Предполагаю, что это связано с длинной имени файла, т.к. оставляя в формуле:

Код

=СЦЕПИТЬ(ТЕКСТ(Бланк_обмера!W4;"ДД.ММ.ГГГГ"))

Файл создается и имя ему присваивается в виде даты.

Сообщение отредактировал graffserg - Четверг, 13.10.2022, 15:51

Дата: Четверг, 13.10.2022, 16:11 | Сообщение № 6

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16674

Репутация: 6479 ±

Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS

Мда. Ответа на свой вопрос я так и не увидел. Ну ладно, как хотите

RAN

Дата: Четверг, 13.10.2022, 16:14 | Сообщение № 7

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Для вмнды Max Len(File.FullName) = 255 (ActiveWorkbook.Path & "\" & strFileName)
Для Excel ~ на 30 символов меньше. Точно не помню

Быть или не быть, вот в чем загвоздка!

Дата: Четверг, 13.10.2022, 16:43 | Сообщение № 8

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Цитата _Boroda_, 13.10.2022 в 14:24, в сообщении № 2 (

)

2. сцепили вы "Бланк обмера " с L1 V1 M2 и W4 и что получили в итоге?

Цитата _Boroda_, 13.10.2022 в 16:11, в сообщении № 6 (

)

Мда. Ответа на свой вопрос я так и не увидел. Ну ладно, как хотите

У меня один только ответ - НИЧЕГО в итоге я не получил из этой сцепки. Как ответить по-другому уме не приложу.

Интересен момент, опустошил всю книгу - и макрос начал работать. По всей видимости, что-то мешает макросу должным образом работать.

К сообщению приложен файл: 7048434.xlsm (56.1 Kb)

Дата: Четверг, 13.10.2022, 17:39 | Сообщение № 9

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16674

Репутация: 6479 ±

Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS

По-моему, здесь только один вариант ответа. Вы получили в результате сцепления какой-то текст. Какой? Переменная strFileName чему равна?

Ладно, 18 часов, я до завтра убегаю. Может, еще кто подключится

Дата: Пятница, 14.10.2022, 00:01 | Сообщение № 10

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Вся загвоздка, на мой взгляд в этой строке макроса:
[vba]

Код

strFileName = "Бланк обмера " & Sheets("Данные").Range("L1").Value

[/vba]
Вот, если на рабочей книге в ячейке L1 присутствует дата, то макрос работает и сохраняет файл "Бланк обмера 02.09.2022.pdf".
Но как только в ячейку вставить формулу:

Код

=СЦЕПИТЬ(ТЕКСТ(Бланк_обмера!W4;"ДД.ММ.ГГГГ");" ";Бланк_обмера!L1;" ";Бланк_обмера!V1;" ";Бланк_обмера!M2)

,
которая должна выводить название файла: "02.09.2022 пом. № 1 (этаж 1) г. Рога и копыта ул. Интересная д. 29.pdf", макрос не работает.

Но парадокс в том, что если листы книги очистить от содержимого и проделать те же манипуляции, как в первом случае - вставить формулу целиком, макрос работает исправно.

Sancho

Дата: Пятница, 14.10.2022, 15:24 | Сообщение № 11

Группа: Проверенные

Ранг: Обитатель

Сообщений: 279

Репутация: 19 ±

Замечаний: 0% ±

2007, 2010, 2013

graffserg, добрый день!
сдается мне вы не указали самое важное - расширение файла в строке
[vba]

Код

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ActiveWorkbook.Path & "\" & strFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=True

[/vba]
правильно скорее так:[vba]

Код

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ActiveWorkbook.Path & "\" & strFileName & ".pdf", Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=True

[/vba]

PS: ну и либо я обход ошибок бы выключил и смотрел конкретно что не так

Сообщение отредактировал Sancho - Пятница, 14.10.2022, 15:32

Дата: Пятница, 14.10.2022, 20:53 | Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Добрый день!

Цитата Sancho, 14.10.2022 в 15:24, в сообщении № 11 (

)

сдается мне вы не указали самое важное - расширение файла в строке

Попробовал, но ничего не получается - результат тот же.
Буду продолжать раскопки.

И вот спустя несколько часов макрос переработал:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    'CellValue = Worksheets("Данные").Range("L1") '№ ячейки для присвоения имени
    SheetName = Worksheets("Данные").Range("L1").Value

    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF


    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол", "Лист1")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Filename, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    Application.ScreenUpdating = True
    MsgBox "Бланк обмера '" & SheetName & "' сохранён в PDF!", vbInformation, "Конец"

    Sheets("Бланк_обмера").Select

End Sub

[/vba]
Самое удивительное, что он работает - все собирает, сохраняет и так как я хочу, но:
1. Я до сих пор не могу добиться того, чтобы имя присваивалось с листа "Данные" ячейка L1, в которой находится все таже злополучная формула:

Код

=СЦЕПИТЬ(ТЕКСТ(Бланк_обмера!W4;"ДД.ММ.ГГГГ");" ";Бланк_обмера!L1;" ";Бланк_обмера!V1;" ";Бланк_обмера!M2)

Я пробовал несколько вариантов, но результат:
[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
В этом случае выдает ошибку 1004.

[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Filename, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
[/code][/vba]
В этом случае появляется файл pdf, но его название - название файла Excel!!

[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & SheetName & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
В этом случае выдает ошибку 1004.

2. Еще одно но, но не особо существенное. Если к примеру выбран один лист и он пустой ( в моем случает "Лист1"), то макрос срабатывает на уведомление.
[vba]

Код

Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол", "Лист1")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"

[/vba].
А вот если выбрано несколько листов и среди них есть пустой лист, то макрос это уведомление пропускает.

Помогите разобраться и добить данный вопрос до конца.
Спасибо.

Добрый день!

Цитата Sancho, 14.10.2022 в 15:24, в сообщении № 11 (

)

сдается мне вы не указали самое важное - расширение файла в строке

Код

=СЦЕПИТЬ(ТЕКСТ(Бланк_обмера!W4;"ДД.ММ.ГГГГ");" ";Бланк_обмера!L1;" ";Бланк_обмера!V1;" ";Бланк_обмера!M2)

Я пробовал несколько вариантов, но результат:
[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
В этом случае выдает ошибку 1004.

[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Filename, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
[/code][/vba]
В этом случае появляется файл pdf, но его название - название файла Excel!!

[vba]

Код

[/vba].
А вот если выбрано несколько листов и среди них есть пустой лист, то макрос это уведомление пропускает.

Помогите разобраться и добить данный вопрос до конца.
Спасибо.graffserg

Сообщение отредактировал graffserg - Суббота, 15.10.2022, 00:43

СообщениеДобрый день!

Цитата Sancho, 14.10.2022 в 15:24, в сообщении № 11 (

)

сдается мне вы не указали самое важное - расширение файла в строке

Код

=СЦЕПИТЬ(ТЕКСТ(Бланк_обмера!W4;"ДД.ММ.ГГГГ");" ";Бланк_обмера!L1;" ";Бланк_обмера!V1;" ";Бланк_обмера!M2)

Я пробовал несколько вариантов, но результат:
[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
В этом случае выдает ошибку 1004.

[vba]

Код

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Filename, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

[/vba]
[/code][/vba]
В этом случае появляется файл pdf, но его название - название файла Excel!!

[vba]

Код

Автор - graffserg
Дата добавления - 14.10.2022 в 20:53

Дата: Суббота, 15.10.2022, 20:33 | Сообщение № 13

Группа: Пользователи

Ранг: Участник

Сообщений: 84

Репутация: 1 ±

Замечаний: 0% ±

2010

Ура!!! Я нашел причину - ЗАПРЕЩЕННЫЕ ЗНАКИ в имени файла.
Вот итог:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    SheetName = Sheets("Данные").Range("L1").Value

    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF


    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If

     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
     xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    'ActiveWorkbook.Path & "\" & "Бланк обмера '" & SheetName & ".pdf", Quality:= _
    'xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    'OpenAfterPublish:=True

    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в PDF!", vbInformation, "Конец"

    Sheets("Бланк_обмера").Select

End Sub

[/vba]

Сообщение отредактировал graffserg - Суббота, 15.10.2022, 20:35

СообщениеУра!!! Я нашел причину - ЗАПРЕЩЕННЫЕ ЗНАКИ в имени файла.
Вот итог:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    SheetName = Sheets("Данные").Range("L1").Value

    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF


    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If

     ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
     xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    'ActiveWorkbook.Path & "\" & "Бланк обмера '" & SheetName & ".pdf", Quality:= _
    'xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    'OpenAfterPublish:=True

    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в PDF!", vbInformation, "Конец"

    Sheets("Бланк_обмера").Select

End Sub

[/vba]

Автор - graffserg
Дата добавления - 15.10.2022 в 20:33

graff9540

Дата: Четверг, 06.04.2023, 12:41 | Сообщение № 14

Группа: Пользователи

Ранг: Новичок

Сообщений: 23

Репутация: 0 ±

Замечаний: 0% ±

Всем привет!!
Подскажите пожалуйста, возможно ли в данный макрос:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    SheetName = Sheets("Данные").Range("L1").Value

    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF


    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    'ActiveWorkbook.Path & "\" & "Бланк обмера '" & SheetName & ".pdf", Quality:= _
    'xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    'OpenAfterPublish:=True

    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в PDF!", vbInformation, "Конец"

    Sheets("Бланк_обмера").Select

End Sub

[/vba]
дописать код с возможностью сохранения файла еще и в формате EXCEL.
В процессе работы понял, что под рукой нужно иметь два файла - исходник и pdf.
Спасибо.

Всем привет!!
Подскажите пожалуйста, возможно ли в данный макрос:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    SheetName = Sheets("Данные").Range("L1").Value

    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF


    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    'ActiveWorkbook.Path & "\" & "Бланк обмера '" & SheetName & ".pdf", Quality:= _
    'xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    'OpenAfterPublish:=True

    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в PDF!", vbInformation, "Конец"

    Sheets("Бланк_обмера").Select

End Sub

[/vba]
дописать код с возможностью сохранения файла еще и в формате EXCEL.
В процессе работы понял, что под рукой нужно иметь два файла - исходник и pdf.
Спасибо.graff9540

СообщениеВсем привет!!
Подскажите пожалуйста, возможно ли в данный макрос:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    SheetName = Sheets("Данные").Range("L1").Value

    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF


    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    'ActiveWorkbook.Path & "\" & "Бланк обмера '" & SheetName & ".pdf", Quality:= _
    'xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    'OpenAfterPublish:=True

    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в PDF!", vbInformation, "Конец"

    Sheets("Бланк_обмера").Select

End Sub

Автор - graff9540
Дата добавления - 06.04.2023 в 12:41

graff9540

Дата: Пятница, 07.04.2023, 15:33 | Сообщение № 15

Группа: Пользователи

Ранг: Новичок

Сообщений: 23

Репутация: 0 ±

Замечаний: 0% ±

Всем привет!
Вот, нашел в готовых решениях макрос и подогнал под себя, вроде все работает и устраивает (время покажет):
[vba]

Код

Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "c:\TEMP"     'папка для сохранения резервной копии
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату-время
        strDate = Format(Now, "dd-mm-yy hh-mm")
        FileNameXls = strPath & "\" & Sheets("Данные").Range("A1").Value & " " & strDate & ".xlsm"   'или xlsm
        ActiveWorkbook.SaveCopyAs FileName:=FileNameXls
    Else 'если путь не существует - выводим сообщение
        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
    End If
End Sub

[/vba]
Подскажите пожалуйста, как можно объединить эти два макроса в один? Хочется нажать кнопку и получить на выходе 2 файла: один в pdf формате, а другой в xlsm, т.е. копию

graff9540

Дата: Пятница, 07.04.2023, 15:58 | Сообщение № 16

Группа: Пользователи

Ранг: Новичок

Сообщений: 23

Репутация: 0 ±

Замечаний: 0% ±

Вот, получилось объединить макросы:
[vba]

Код

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    strPath = "C:\Users\Admin\Desktop"     'папка для сохранения резервной копии

    SheetName = Sheets("Данные").Range("L1").Value

    FinalFileName = strPath & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF
    FinalFileName1 = strPath & SheetName & ".xlsm" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в xlsm

    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    FileNameXls = FinalFileName1
    ActiveWorkbook.SaveCopyAs Filename:=FileNameXls


    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в формате PDF и XLSM!", vbInformation, "Конец"
        Exit Sub
    Sheets("Бланк_обмера").Select

End Sub

[/vba]

Вроде все работает.
Может есть огрехи? Буду признателен за оказанную помощь.

Вот, получилось объединить макросы:
[vba]

Код

[/vba]

Вроде все работает.
Может есть огрехи? Буду признателен за оказанную помощь.graff9540

Сообщение отредактировал graff9540 - Пятница, 07.04.2023, 16:21