[[20220222163550]]　『PDF化のVBA』（ある人）　ページの最後に飛ぶ

『PDF化のVBA』（ある人）

複数のファイルをPDF化するVBAで
一番左のシート（シートの名前は決まっている）のみを除外してPDF化するマクロを作りたいのですが、うまくいきません。
どうしたらいいでしょうか？

Sub Convert_to_PDF()

    Dim strDirPath As String
    strDirPath = Search_Directory() 'フォルダの選択
    If Len(strDirPath) = 0 Then Exit Sub
    Call Make_Dir(strDirPath, "\PDF") 'フォルダ作成
    Call Search_Files(strDirPath)
End Sub

Private Function Search_Directory() As String 'フォルダの選択

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Private Sub Make_Dir(ByVal Path As String, ByVal Dn As String)

    If Dir(Path & Dn, vbDirectory) = "" Then 'フォルダ存在確認
        MkDir Path & Dn 'フォルダ作成
    End If
End Sub

Private Sub Search_Files(ByVal Path As String)

    Dim strFile As String, strET As String
    strFile = Dir(Path & "\" & "*.*") 'ファイル確認
    Application.ScreenUpdating = False
    Do Until strFile = ""
        If ThisWorkbook.FullName <> Path & "\" & strFile Then
        Call Conv_PDF(Path, "\" & strFile)
        End If
        strFile = Dir() '次のファイル確認
        Loop
    Application.ScreenUpdating = True
    MsgBox ("PDF化完了!")
End Sub

Private Function Get_Extension(ByVal Path As String) As String '拡張子取得

    Dim i As Long
    i = InStrRev(Path, ".", -1, vbTextCompare)
    If i = 0 Then Exit Function
    Get_Extension = Mid$(Path, i + 1)
End Function

Private Sub Conv_PDF(ByVal Path As String, ByVal Fn As String)
Application.DisplayAlerts = False

    Dim filePath As String, objOffice As Object
    filePath = Path & "\PDF" & Left$(Fn, InStrRev(Fn, ".")) & "pdf"
    Path = Path & Fn
    Select Case Get_Extension(Fn) 'ファイル名から拡張子取得
        Case "xls", "xlsx", "xlsm" 'Excel97-2003,Excel2007以降
                Set objOffice = Excel.Application
            With objOffice.Workbooks.Open(Path)
                .ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=filePath, Openafterpublish:=False
                .Close
            End With
        Case "doc", "docx" 'Word97-2003,Word2007以降
            Set objOffice = CreateObject("Word.Application")
            With objOffice.Documents.Open(Path)
                .ExportAsFixedFormat OutputFileName:=filePath, _
                ExportFormat:=17
                .Close
            End With
            objOffice.Quit
        Case "ppt", "pptx" 'Powerpoint97-2003,Powerpoint2007以降
            Set objOffice = CreateObject("Powerpoint.Application")
            With objOffice.Presentations.Open(Path)
                .SaveAs Filename:=filePath, FileFormat:=32
                .Close
            End With
            objOffice.Quit
                Application.DisplayAlerts = True
    End Select
End Sub

＜使用 Excel：Excel2016、使用 OS：unknown ＞

手抜きですので、希望通りにはならないかも。

  With objOffice.Workbooks.Open(Path)
      .ExportAsFixedFormat Type:=xlTypePDF, From:=2, _　’←ここ修正
      Filename:=filePath, Openafterpublish:=False
      .Close
  End With

（わからん） 2022/02/22(火) 17:25

返信いただいた内容では動きませんでしたので修正したら動きました。
しかし、ヘッダーに印刷数をカウントしており、2ページから印刷しているためか、
2から始まってしまいます。
ヘッダーは1ページからスタートさせたいのですが、マクロでは難しいですかね？
（ある人） 2022/02/23(水) 08:00

 シートをグループ化すればいいんですが、
 WorksheetsオブジェクトにはExportAsFixedFormatメソッドがないので、
 Selectしてから、ActiveSheetに対してExportAsFixedFormatしてます。
 ん～？うまくいくかな？って感じです

  Dim ind() As Integer
  With objOffice.Workbooks.Open(Path)
      ReDim ind(2 To .Worksheets.Count)
      For i = 2 To .Worksheets.Count
         ind(i) = i
      Next
      .Worksheets(ind).Select
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filePath, Openafterpublish:=False
      .Close
  End With
（´・ω・`） 2022/02/23(水) 08:19

SheetsクラスのSelectメソッドが失敗しましたとエラーがでます。

2ページ以降がアクティブでないからだと思いますが、
1ページをWorksheets(1).Activateでアクティブにしたところ、
1ページのみしかPDF化されませんでした。

（ある人） 2022/02/23(水) 09:50

すいません、Worksheets(1).Activateでアクティブにしたところ
1ページのみでなく、全ページPDF化されたので
教えていただいたコードの意味がなくなってしまいました。

（ある人） 2022/02/23(水) 09:56

 それでは 
  With objOffice.Workbooks.Open(Path)
      .Worksheets(1).Delete
      .ExportAsFixedFormat Type:=xlTypePDF, Filename:=filePath, Openafterpublish:=False
      .Close False
  End With
 ではだめですか
（´・ω・`） 2022/02/23(水) 10:23

 削除じゃなくて非表示にするほうが安全かも
（´・ω・`） 2022/02/23(水) 10:26

ありがとうございます。
.Worksheets(1).Visible = xlSheetHiddenとすることで希望通りの動きをしてくれました。
しかし、すべてのをPDF変換したあと最後に
エラー91（オブジェクト変数または With ブロック変数が設定されていません。）
が出てしまいます。
どこかでSetを入れてやらないとダメですかね？
（ある人） 2022/02/23(水) 15:38

 >エラー91（オブジェクト変数または With ブロック変数が設定されていません。）
 どこででますか？

 >どこかでSetを入れてやらないとダメですかね？
 ちょっと意図しているところがわかりません
（´・ω・`） 2022/02/23(水) 16:27

.Worksheets(1).Visible = xlSheetHidden
↑ここで出ます。
PDF化はでき、一通りの作業が終わったら
エラー91がでてしまいます。
（ある人） 2022/02/24(木) 08:29

 PDFに書き出したあと、その前の行でエラーになるっていうのが、 よくわかりません
 現状のコードはどうなってますか？
（´・ω・`） 2022/02/24(木) 13:03

Sub Auto_Open()
Call Convert_to_PDF
End Sub
Sub Convert_to_PDF()

    Dim strDirPath As String
    strDirPath = Search_Directory() 'フォルダの選択
    If Len(strDirPath) = 0 Then Exit Sub
    Call Make_Dir(strDirPath, "\PDF") 'フォルダ作成
    Call Search_Files(strDirPath)
End Sub

Private Function Search_Directory() As String 'フォルダの選択

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Private Sub Make_Dir(ByVal Path As String, ByVal Dn As String)

    If Dir(Path & Dn, vbDirectory) = "" Then 'フォルダ存在確認
        MkDir Path & Dn 'フォルダ作成
    End If
End Sub

Private Sub Search_Files(ByVal Path As String)

    Dim strFile As String, strET As String
    strFile = Dir(Path & "\" & "*.*") 'ファイル確認
    Application.ScreenUpdating = False
    Do Until strFile = ""
        If ThisWorkbook.FullName <> Path & "\" & strFile Then
        Call Conv_PDF(Path, "\" & strFile)
        End If
        strFile = Dir() '次のファイル確認
        Loop
    Application.ScreenUpdating = True
    MsgBox ("PDF化完了!")
End Sub

Private Function Get_Extension(ByVal Path As String) As String '拡張子取得

    Dim i As Long
    i = InStrRev(Path, ".", -1, vbTextCompare)
    If i = 0 Then Exit Function
    Get_Extension = Mid$(Path, i + 1)
End Function

Private Sub Conv_PDF(ByVal Path As String, ByVal Fn As String)
Application.DisplayAlerts = False

    Dim filePath As String, objOffice As Object
    filePath = Path & "\PDF" & Left$(Fn, InStrRev(Fn, ".")) & "pdf"
    Path = Path & Fn
    Select Case Get_Extension(Fn) 'ファイル名から拡張子取得
        Case "xls", "xlsx", "xlsm" 'Excel97-2003,Excel2007以降
                Set objOffice = Excel.Application

  With objOffice.Workbooks.Open(Path)
★    .Worksheets(1).Visible = xlSheetHidden
      .ExportAsFixedFormat Type:=xlTypePDF, Filename:=filePath, Openafterpublish:=False
      .Close False
  End With

        Case "doc", "docx" 'Word97-2003,Word2007以降
            Set objOffice = CreateObject("Word.Application")
            With objOffice.Documents.Open(Path)
                .ExportAsFixedFormat OutputFileName:=filePath, _
                ExportFormat:=17
                .Close
            End With
            objOffice.Quit
        Case "ppt", "pptx" 'Powerpoint97-2003,Powerpoint2007以降
            Set objOffice = CreateObject("Powerpoint.Application")
            With objOffice.Presentations.Open(Path)
                .SaveAs Filename:=filePath, FileFormat:=32
                .Close
            End With
            objOffice.Quit
                Application.DisplayAlerts = True
    End Select
End Sub

★を付けた場所がエラーで黄色くなっています。
（ある人） 2022/02/24(木) 14:06

 やっぱりよく分かりませんが、

  ★の場所でエラーになったときの、Path の値はどうなってますか？
  そのPathで指定されたファイルもPDF化ができてるんですか？
（´・ω・`） 2022/02/24(木) 15:47

コメント返信：

[ 一覧(最新更新順) ]

[[20220222163550]] 『PDF化のVBA』（ある人） ページの最後に飛ぶ

[[20220222163550]]　『PDF化のVBA』（ある人）　ページの最後に飛ぶ