Страницы: 1
RSS
Сохранение листов а формате pdf в определенные папки
 
Добрый день.

Помогите пожалуйста.  Возникла потребность сохранять листы с помощью макроса в формате pdf в папки с названиями указанными в листах.  Подробнее расписано во вложении.  
 
Baragoz, держите.
Код
' Вызов с кнопки 2ого листа
Sub sh2Call()
    saveAsPdf "Лист1!A7", "Лист1!A4"
End Sub

' Вызов с кнопки 3ого листа
Sub sh3Call()
    saveAsPdf "Лист1!B7", "Лист1!B4"
End Sub

Sub saveAsPdf(folderNameCellLink As String, fileNameCellLink As String)

    ' Название папки (нужен год из даты)
    folderNameRn = WorksheetFunction.Text(Range(folderNameCellLink).Value, "YYYY")
    pdfPath = GetDesktop & "\" & "Протоколы\" & folderNameRn & "\"
    
    ' Название файла
    filenameRn = Range(fileNameCellLink).Value
    pdfName = filenameRn & ".pdf"
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Проверка существования \ создание папки "Протоколы"
    If Not fso.FolderExists(GetDesktop & "\" & "Протоколы\") Then fso.CreateFolder (GetDesktop & "\" & "Протоколы\")
    ' Проверка существования \ создание папки с годом
    If Not fso.FolderExists(pdfPath) Then fso.CreateFolder (pdfPath)
    ' При наличии в правильной папке файла с нужным именем - удалить файл
    If fso.FileExists(pdfPath & pdfName) Then fso.DeleteFile (pdfPath & pdfName)
    ' Сохранить файл как PDF. ПРИМЕЧАНИЕ: работает, если на листе есть хотя бы 1 непустая ячейка
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=pdfPath & pdfName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    
    Set fso = Nothing
End Sub

'https://excel.tips.net/T008233_Finding_the_Path_to_the_Desktop.html
Function GetDesktop() As String
    Dim oWSHShell As Object

    Set oWSHShell = CreateObject("WScript.Shell")
    GetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing
End Function
Изменено: tolstak - 30.08.2017 17:50:51
In GoTo we trust
 
Суть та же... Но папка должна существовать!
Макрос один. Подвязан к обеим кнопкам. По имени текущего листа определяет столбец, где записаны параметры сохранения.
Код
Sub Печать_PDF()
Dim CurFn As String, CurPath As String, ResFn As String, ResPath As String
Dim cOlFn As Long
Dim tMp As Variant
    
    
    CurFn = ActiveWorkbook.Name
    CurPath = ActiveWorkbook.Path
        
On Error Resume Next
    
    If ActiveSheet.Name = "Лист2" Then
        cOlFn = 1
    ElseIf ActiveSheet.Name = "Лист3" Then
        cOlFn = 2
    Else
        Exit Sub
    End If
    
    ResPath = ThisWorkbook.Sheets("Лист1").Cells(8, cOlFn).Value
    If Len(ResPath) = 0 Then
        tMp = MsgBox("не задана папка для отчета!!!", vbOKOnly + vbCritical, "Макрос ""Печать_PDF"":")
        Exit Sub
    End If
    
    If Len(Dir(ResPath, vbDirectory)) = 0 Then
        tMp = MsgBox("не найдена папка """ & ResPath & """ для отчета!!!", vbOKOnly + vbCritical, "Макрос ""Печать_PDF"":")
        Exit Sub
    End If
    
    ResFn = ThisWorkbook.Sheets("Лист1").Cells(4, cOlFn).Value
On Error GoTo ErrCd
    If Len(Dir(ResPath & "\" & ResFn & ".pdf")) Then
        Kill ResPath & "\" & ResFn & ".pdf"
    End If
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ResPath & "\" & ResFn & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    tMp = MsgBox("Плановое завершение.", vbOKOnly + vbExclamation, "Макрос ""Печать_PDF"":")
    Exit Sub
ErrCd:
    tMp = MsgBox("аварийное завершение!!!", vbOKOnly + vbCritical, "Макрос ""Печать_PDF"":")
End Sub
Если файл уже существует, затирает старый и записывает новый.
Если папка должна создаваться самостоятельно, нужно дорабатывать.
Изменено: PerfectVam - 30.08.2017 18:08:58
Следствие из третьего закона Чизхолма:
"Даже если ясность изложения исключает неверное толкование, все равно найдется кто-то, кто поймет Вас неправильно."
 
Вариант:
Код
Public Sub www()
    Dim s1$, s2$
    With ThisWorkbook.Sheets("Лист1")
        s1 = Environ("USERPROFILE") & "\Desktop\" & Year(.[a7]) & "\"
        s2 = Environ("USERPROFILE") & "\Desktop\" & Year(.[b7]) & "\"
        CreateObject("Shell.Application").Namespace(Left(s1, 3)).NewFolder (Mid(s1, 4))
        CreateObject("Shell.Application").Namespace(Left(s2, 3)).NewFolder (Mid(s2, 4))
        Sheets(2).ExportAsFixedFormat Type:=xlTypePDF, Filename:=s1 & .Cells(4, 1).Value & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        Sheets(2).ExportAsFixedFormat Type:=xlTypePDF, Filename:=s2 & .Cells(4, 2).Value & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
End Sub
;)
Вариант для кнопки(только текущий лист) еще проще:
Код
Public Sub www()
    Dim s1$, n&
    n = ActiveSheet.Index - 1
    With ThisWorkbook.Sheets("Лист1")
        s1 = Environ("USERPROFILE") & "\Desktop\" & Year(.Cells(7, n)) & "\"
        CreateObject("Shell.Application").Namespace(Left(s1, 3)).NewFolder (Mid(s1, 4))
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=s1 & .Cells(4, n).Value & ".pdf"
    End With
End Sub
Изменено: kuklp - 30.08.2017 19:39:43
Я сам - дурнее всякого примера! ...
 
Спасибо всем за то что помогли. Вариант kuklp, проще,  выбрал его,  все работает.  Еще один вопрос ,  как перед годом вставить еще одну папку,  с названием ячейки,  например А5?
Страницы: 1
Наверх