• 締切済み

excel マクロ PDF化の際のエラーについて

エクセルブックを一括で名前をつけてpdfに変換するようなマクロを作ろうとして作ってみました。 基本は、マクロで印刷を一気に行う要領でpdfをアクティブプリンタに設定したのですが、見かけ上pdfファイルが作成されるものの、開くと破損していますとなってしまい、きちんとpdf化が出来ていないようです。 システムフォントを利用～のエラーは回避できたのですが、無理やりファイル名を指定しているせいでこのようになっているのでしょうか。 お手数ですがアドバイスをお願いします。 マクロの記録ではアクティブプリンタを指定して、プリントアウトというものしか記録されないので、プリントアウトのところが何か間違っているとは思うのですが・・・ 以下コードです。 Sub PrtPDF() Dim MyFile As String, MyPath As String Dim wb As Object Dim fn As String If vbNo = MsgBox("フォルダ内のブックの一括印刷を行いますか？", vbYesNo) Then GoTo CloseFile Dim bookname1 As String bookname1 = "Conv.xls" MyPath = ThisWorkbook.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のxlsファイル If LCase(MyFile) = LCase(bookname1) Then MyFile = Dir 'MyFileとbookname1が同じファイルの場合スキップする Do Until MyFile = "" '対象ファイルがなくなるまで Set wb = Workbooks.Open(MyPath & "\" & MyFile) '選択したファイルを開く fn = MyPath & "PDF\" & Range("J4").Value & ".pdf" 'アクティブシートを印刷する。 Application.ActivePrinter = "Adobe PDF on Ne07:" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrtoFileName:=fn 'アクティブブックを閉じる。 ActiveWorkbook.Close MyFile = Dir '次のファイルを検索 If LCase(MyFile) = LCase(bookname1) Then MyFile = Dir 'MyFileとbookname1が同じファイルの場合スキップする Set wb = Nothing Loop '繰り返し GoTo ProcessEnd CloseFile: ActiveWorkbook.Close MsgBox "処理を中止しました。" Exit Sub ProcessEnd: MsgBox "処理が終了しました" End Sub

みんなの回答

  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.2

本家Acrobatをお使いなら、下記がご参考になるでしょう。 http://okwave.jp/qa/q6205938.html フリーソフトなら、 pdfcreatorをお勧めします。 http://sourceforge.jp/projects/pdfcreator/ 一部しか試してないですが、下記にExcel VBAのサンプルコードがあります。 http://www.excelguru.ca/node/21

Asn_Lynx
質問者

お礼

＜自己解決＞ acrobatを通常使うプリンターに設定し、通常の自動印刷ルーチンを作成し流したところ概ねうまくいきました。 いちい保存先を指定して保存する作業に関しては、acrobat上の設定で前もって保存先を指定しておくことで回避できました。 そもそも、保存先をアクロバットで指定できることがスパッと頭から抜け落ちていました。 ファイル移動のひと手間は増えましたが、３０００枚近くのものを一括でpdf化できました。 ご回答ありがとうございました。 ＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊ 以下　コード Sub BAPforPDF() Dim MyFile As String, MyPath As String Dim wb As Object Dim WT1 As Variant, WT2 As Variant Dim fn As String If vbNo = MsgBox("フォルダ内のブックの一括印刷を行いますか？", vbYesNo) Then GoTo CloseFile Dim bookname1 As String bookname1 = "ZConv.xls" 'MsgBox "Process1" 'ブックパスの取得及びファイルのオープンメソッド MyPath = ThisWorkbook.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のxlsファイル If LCase(MyFile) = LCase(bookname1) Then MyFile = Dir 'MyFileとbookname1が同じファイルの場合スキップする Do Until MyFile = "" '対象ファイルがなくなるまで Set wb = Workbooks.Open(MyPath & "\" & MyFile) '選択したファイルを開く 'アクティブシートの印刷設定をPDFに変更する。 With ActiveSheet.PageSetup .PrintTitleRows = "" .PrintTitleColumns = "" End With ActiveSheet.PageSetup.PrintArea = "$A$1:$BV$53" With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.78740157480315) .RightMargin = Application.InchesToPoints(0.78740157480315) .TopMargin = Application.InchesToPoints(0.984251968503937) .BottomMargin = Application.InchesToPoints(0.984251968503937) .HeaderMargin = Application.InchesToPoints(0.511811023622047) .FooterMargin = Application.InchesToPoints(0.511811023622047) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = True .CenterVertically = True .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 .PrintErrors = xlPrintErrorsDisplayed End With WT1 = Now + TimeValue("0:00:02") Application.Wait WT1 'アクティブシートを印刷する。 ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True WT2 = Now + TimeValue("0:00:03") 'If vbNo = MsgBox("Run for Waiting?", vbYesNo) Then GoTo CF Application.Wait WT2 CF: '※変更を保存せずに閉じる場合は(1)のコードをアクティブに、保存して閉じる場合は(2)のコードをアクティブにすること！ '※検証の際は(3)をアクティブにすること！ '(1)アクティブブックの変更を保存せずに閉じる。 Application.DisplayAlerts = False ActiveWorkbook.Close Application.DisplayAlerts = True '(2)アクティブブックの変更を保存して閉じる。 ' ActiveWorkbook.Save ' ActiveWorkbook.Close '(3)別名で保存 'fn = MyPath & "Pr\PDF-" & (Range("J4").Value) ' ActiveWorkbook.SaveAs Filename:=fn ' ActiveWorkbook.Close MyFile = Dir '次のファイルを検索 If LCase(MyFile) = LCase(bookname1) Then MyFile = Dir 'MyFileとbookname1が同じファイルの場合スキップする Set wb = Nothing Loop '繰り返し GoTo ProcessEnd 'Msgbox "Process9" CloseFile: ActiveWorkbook.Close MsgBox "処理を中止しました。" Exit Sub ProcessEnd: MsgBox "処理が終了しました" End Sub ＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

回答No.1

残念ながら ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, PrtoFileName:=fn でやってることは、印刷ダイアログにある 「ファイルへ保存」 にチェックを入れて、保存先を指定しているのと同じ。 それで保存されたファイルは PDF ではなく、一般的なプリンターで汎用的に読み込んで印刷できる形式のファイル。 http://www.nikkeibp.co.jp/archives/104/104162.html Office 2007 か Office 2010 なら Acrobat 不要で PDF 出力ができ、当然ながら VBA からもコントロールが可能。 下記は Excel 2007 ん時に作ってみたやつ。 http://blog.temtecomai.net/archives/51144291.html Office 2003 以前なら Acrobat 以外の PDF 出力プリンターを使うのが一般的か。(要求そのものがあまり一般的ではないと思うけど) http://d.hatena.ne.jp/morningmist7/20080623/1214216982 Acrobat を使って無理やり PDF 出力するサンプルもあった。 http://note.phyllo.net/?eid=1106046

Asn_Lynx
質問者

お礼

＜自己解決＞ acrobatを通常使うプリンターに設定し、通常の自動印刷ルーチンを作成し流したところ概ねうまくいきました。 いちい保存先を指定して保存する作業に関しては、acrobat上の設定で前もって保存先を指定しておくことで回避できました。 やはり、.pdfという拡張子を無理やりつけただけのファイルとなっていたのですね。 アクロバットの設定を確認して利用したところ、通常の印刷ルーチンで望む結果が得られました。 ご回答ありがとうございました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • マクロ処理後のファイル名変更について

    マクロでいくつかの処理を行った後、もとのファイル名に 「済＋ファイル名」としてファイル名を変更して終了をしたいのですが、 どのようにすればできるのかわかりません。 どなたか教えていただけますか？ イメージ） 処理前のファイル名：サラダ.xls、お肉.xls・・・ 処理後のファイル名：済サラダ.xls、済お肉.xls・・・ Dim myPath As String Dim myFile As String Dim w As Workbook Dim s As Worksheet myPath = ThisWorkbook.Path & "\" myFile = Dir(myPath & "*.xls") Do Until myFile = "" If myFile <> ThisWorkbook.Name Then Set w = Workbooks.Open(myPath & myFile) For Each s In w.Worksheets s.Range・・・・・ 　　　　・・・・・・・・ 　　　　・・・・・・・・ Next w.Close savechanges:=True End If myFile = Dir() Loop MsgBox "完了しました。" End Sub

  • VBAのDirをつかってブックを検索した後のことについて。

    VBAのDirをつかってブックを検索した後のことについて。 お世話になっております。 以下のコードでファイルを開いたものをアクティブにするにはどうすればよろしいでしょうか？ 流れ １）以下のコードでブックを開き、このブックのセルを検索、コピー ２）貼り付けブックを開いて貼り付け ３）もう一度以下のブックで開いたブックのセル検索、コピー ４）貼り付けブックに貼り付け 流れの３）でつっかかってます。 どうか宜しくお願い致します。 ///コード/// Dim myPath As String Dim myFile As String myPath = "C:\Documents and Settings\1234567\デスクトップ\棚卸" & "\" myFile = Dir(myPath & "*棚卸一覧表(1G).xls") If myFile <> "" Then Workbooks.Open Filename:=myPath & myFile Else MsgBox "ファイルは見つかりませんでした" End If

  • EXCEL　マクロ　につきまして

    お世話になっております。 以前、同様の質問をさせていただきまして、 その拡張バージョンをつくりたいと考えております。 Sub macro1() Dim myPath As String Dim myFile As String Dim c As Long Dim LastRowr As Long Application.ScreenUpdating = False myPath = ThisWorkbook.Path & "\" myFile = Dir(myPath & "*.xls") c = 6 Do Until myFile = "" If myFile <> ThisWorkbook.Name Then Workbooks.Open Filename:=myPath & myFile lastrow = Worksheets("特定のシート").Range("A65536").Row ThisWorkbook.Worksheets(2).Cells(1, c).Resize(lastrow, 1).Value = Worksheets("特定のシート").Range("H1").Resize(lastrow, 1).Value Workbooks(myFile).Close False c = c + 1 End If myFile = Dir() Loop Application.ScreenUpdating = True On Error Resume Next ActiveSheet.Name = Format(Date, "mmdd") On Error GoTo 0 End Sub こちらは"特定のシート"の特定の列（H）のみをひたすらフォーマットに 貼り付けていくものですが、コピペしたい列が増えた場合（数は一定ではない） のバージョンができればと思っております。 正直まったくわかりません。 1)データが何列あるかは不定 2)行1~3には自動的に何らかのデータが振られてしまっており（連番等） 　データの終わりとして使えそうなのは、行4に「0」が入っていること 　（但し0は非表示にしております） "特定のシート"名・データがH列から始まる等は変わりません。 現状の記述を改修、もしくは全とっかえでも構いません。 なにとぞよろしくお願い致します。

  • VBAでブック名の拡張子を除去してシートにコピー

    VBA初心者でコード作成で困っております。 下記の通りコードを組みましたが、シート名をブック名に変更して 保存したいのですが、このコードですと拡張子までついてしまいます。 拡張子を除去するためにはどうすればよいでしょうか？ アドバイス宜しくお願い致します。 Sub test() 'シート名の変更 Dim MyPath As String Dim MyFile As String Dim Wb As Workbook MyPath = "C:\TEST\" MyFile = Dir(MyPath & "*.xlsx") Do While MyFile <> "" Set Wb = Workbooks.Open(MyPath & MyFile) ActiveSheet.Name = ActiveWorkbook.Name Application.DisplayAlerts = False Wb.Save Application.DisplayAlerts = True Wb.Close (False) MyFile = Dir() Loop End Sub

  • 一部マクロを変更したいので教えてください。

    現在、下記のようなマクロを使用しています。 Sub sample() Dim myFile As String, myPath As String, i As Long Application.ScreenUpdating = False myPath = InputBox("フルパスでフォルダーを指定") myFile = Dir(myPath & "\*.xls", vbNormal) Do Workbooks.Open myPath & "\" & myFile For i = 1 To ActiveWorkbook.Sheets.Count If WorksheetFunction.CountA(Sheets(i).Range("B7:B11")) = 0 Then Sheets(i).Range("B7") = "*" End If Next ActiveWorkbook.Close True myFile = Dir() Loop While myFile <> "" Application.ScreenUpdating = True MsgBox "完了 ！！" End Sub 上から４行目のmyPath = InputBox("フルパスでフォルダーを指定")を パスを入力するマクロではなくてもっと簡単にフォルダを選択するマクロに変更したいのですが どうすればいいですか？

  • Excel 2010 VBA:ファイル名を読み込む

    下は複数のcsvファイルを一つに合体するVBAです。これにシートの右端に読み取ったファイル名を追加するにはどうしたらよいでしょうか。 よろしくお願いします。 Sub macro1() Dim myPath As String Dim myFile As String Dim s As String myPath = ThisWorkbook.Path & "\" On Error Resume Next Kill myPath & "合体版.csv" On Error GoTo 0 myFile = Dir(myPath & "*.csv") If myFile = "" Then Exit Sub Open myPath & "合体版.csv" For Output As #1 Do Until myFile = "" Open myPath & myFile For Input As #2 Do Until EOF(2) Line Input #2, s Print #1, s Loop Close #2 myFile = Dir() Loop Close #1 End Sub

  • Excelマクロのエラー

    お世話になります。 マクロは、超初心者で只今、本やネットで勉強中なのですが、本の通りに作成しましたが、 エラーが出てしまいます。 急いでおりまして、大変お手数ですがご教示お願いできますでしょうか？ Excel2007でマクロを作成中（実際に業務で使用する環境は2003です）。 2点あります。 (1)サブフォルダ内の全ブックを開く 　ファイルは開くのですが、下記のエラーが出てしまいます。 　C：￥...... "\web保存\"が見つかりません。ファイル名およびファイルの保存場所が 　正しいかどうかを確認してください。 (2)開いたファイルをhtm保存する。 　htm保存できるのですが、ファイル名が「●●●.xls.htm」 　となってしまい、元のファイル名の.xlsの拡張子が付いたままです。 　ファイル名を変えず、「●●●.htm」となるようにしたいです。 どうぞ宜しくお願い致します。 (1)サブフォルダ内の全ブックを開く Sub 全ブックを開く() Dim パス名 As String Dim ファイル名 As String パス名 = ThisWorkbook.Path & "\web保存\" ファイル名 = Dir(パス名 & "*.xls*") Do While ファイル名 <> " " Workbooks.Open パス名 & ファイル名 ファイル名 = Dir() Loop End Sub (2)開いたファイルをhtm保存する Sub htm保存() Dim wb As Workbook Dim wbname As String For Each wb In Workbooks wb.Activate If wb.Name <> ThisWorkbook.Name Then wb.SaveAs FileName:=ThisWorkbook.Path & "\" & wb.Name & ".htm", FileFormat:=xlHtml, CreateBackup:=False wb.Close savechanges:=False End If Next End Sub

  • Excelのマクロで同じ処理を実行

    Excelのマクロについてです。 この度、フォルダ内にあるデータから傾きを抽出して、 データシートにまとめる作業を求められています。 一度ずつ開いて行うのが大変なので、マクロを用いようと思っています。 Sub マクロループ() Dim myPath As String Dim myFile As String myPath = "C:\test\" myFile = Dir(myPath & "*.CSV*") Do Until myFile = "" Workbooks.Open myPath & myFile （ ActiveWindow.ScrollRow = 2 ActiveWindow.ScrollRow = 3 ~ ~ ActiveSheet.Shapes("グラフ 1").IncrementLeft -125.25 ActiveSheet.Shapes("グラフ 1").IncrementTop 21.75 Application.CommandBars("Format Object").Visible = False ） ActiveWorkbook.Close True myFile = Dir() Loop End Sub ~の部分に省略した処理が入ります。 これでエラーなどは起きないのですが、開いて閉じるだけになってしまっています。 （）で括られた部分だけで実行すると、そのファイルで傾きを表示してくれます。 これを全ファイルでやりたいのですが、お力添えをお願いします。 また、それぞれで得られた傾きをデータシートに自動で入力することなどができればそれも教えていただければ幸いです。 どうかよろしくお願いします。

  • 実行時エラー9　インデックスが有効範囲にありません！

    プログラムを編集するところ、実行時エラー９：インデックスが有効範囲にありません」ができてた。調べたのですが、原因は分からない、皆さん、助けてください。 以下はあるフォルダーを選定して、セルの値と一致するファイルを探し出して、シートＡの中のデータを取り上げて、コピーしないです。けど、エラーが出てきた。皆さん。よろしくお願いします。 Sub test() Dim forName, bookName As String Dim x, y, l As Long Const cnsDIR = "\*.xls" Dim bFound As Boolean Dim myBook, actBook As Workbook Dim mySheet, actSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then myPath = .SelectedItems(1) End If End With forName = Dir(myPath, vbDirectory) If Dir(myPath, vbDirectory) = "" Then MsgBox "It's nothing!", vbExclamation Exit Sub End If bFound = False For x = 2 To 7 Step 1 bookName = Dir(myPath & cnsDIR, vbNormal) Do While bookName <> "" l = InStrRev(bookName, ".xls") If Mid(bookName, l - 4, 4) = Format(Cells(4, x), "0000") Then bFound = True Exit Do 'hang/lie Else bookName = Dir() End If Loop If bFound = False Then Rtn = MsgBox("This is no found. Do you want to continue?", vbYesNo, "選択") If Rtn = vbNo Then Exit For End If Windows(bookName).Activate actSheet = ActiveWorkbook.Sheets For Each actSheet In Worksheets If ActiveSheet.Name = "A" Then Application.Union(Range("C55:F55"), Range("H55:I55")).Copy ThisWorkbook.Sheets(4).Range("B5").PasteSpecial Paste:=xlValues, Transpose:=True End If Next Next x End Sub

  • エクセルVBAで、ある特定な場所にあるブックが開いていたら閉じたい

    こちらでお世話になった者です。その節はありがとうございました。 http://okwave.jp/qa3972230.html 他のブックが開いているとエラーになるので、フォームのブックが開いていたら、 マクロの最初に閉じてしまいたいと思います。 dbase.xls formフォルダ 　001.xls 　002.xls 　003.xls のようなフォルダ構造になっていて、001～003.xlsは入力フォームです。 dbase.xlsを開いて、マクロを貼り付けたボタンをクリックすると、すべてのフォームの データがdbase.xlsに取り込まれます。 ↓のような感じで、最初にメッセージが表示されるようにしたのですが、 自分以外の、formフォルダにあるブックが開いていたらそれをすべて閉じる 方法を教えていただけますか。 Sub data_torikomi() MsgBox ("開いている他のエクセルブックをすべて閉じてください") Dim Fn As String Dim myPath As String Dim dbBkSh As Worksheet Dim i As Long Set dbBkSh = Workbooks("dbase.xls").Worksheets("一覧表") myPath = ThisWorkbook.Path & "\" Fn = Dir(myPath & "form\*.xls") i = 1 　　……

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する