フォルダ内のエクセルを全シート一括印刷したい

フォルダ内にエクセルが１０以上入っており、
そのエクセルの全シートを一括で印刷させるマクロを組みました。

下記のコードで、現在フォルダ名を指定していますが、
カレントフォルダ内（マクロが格納されているフォルダ）
で実装するにはどのように記述を変えたらよいでしょうか。
★★★の部分を変えたらいいのかと思うのですが
どのようにしたらよいかわからず。。

宜しくお願いしますｍ(_ _)ｍ

Sub 一括印刷()

ChDir ThisWorkbook.Path

Dim Fol As String
Dim Fname As String
Dim Ws As Worksheet

Fol = "★★★現在はフォルダパスを記載している★★"
Fname = Dir(Fol & "*.xls")

Do While Fname <> ""
If Fname <> ThisWorkbook.Name Then
Workbooks.Open Fol & "" & Fname
For Each Ws In Worksheets
Ws.PrintOut
Next
Workbooks(Fname).Close SaveChanges:=False
End If
Fname = Dir()
Loop

End Sub

行動規範の内容に同意します

回答3件

ベストアンサー

フォルダを指定しなければカレントを参照します。

VBA
1Fname = Dir(Fol & "*.xls")
2 ↓
3Fname = Dir("*.xls")

投稿2019/03/04 05:23

ttyp03

総合スコア17000

noncha930

2019/03/04 06:53

ありがとうございます。 Fol = "★★★現在はフォルダパスを記載している★★" を削除し Fname = Dir("*.xls") という記述に変更したところ下記のエラーが出てしまいました。 -------- "ファイル名"が見つかりません。ファイル名およびファイルの保存場所が正しいかどうかを確認してください。最近使用したファイルの一覧からファイルを開こうとしている場合は、そのファイルの名前が変更されていないこと、移動または削除されていないことを確認してください。 ------------------ 恐縮ですが、理由がわからないので教えていただけると幸いです＞＜

noncha930

2019/03/04 06:54

Sub 一括印刷() ChDir ThisWorkbook.Path Dim Fol As String Dim Fname As String Dim Ws As Worksheet Fname = Dir("*.xls") Do While Fname <> "" If Fname <> ThisWorkbook.Name Then Workbooks.Open Fol & "\" & Fname For Each Ws In Worksheets Ws.PrintOut Next Workbooks(Fname).Close SaveChanges:=False End If Fname = Dir() Loop End Sub

ttyp03

2019/03/04 06:55

失礼しましたOpenのところも修正しないとダメでした。 Workbooks.Open Fname

noncha930

2019/03/04 07:03

できました！！いつもありがとうございます＞＜大変助かりました！

noncha930

2019/05/14 04:14

Sub 一括印刷() ChDir ThisWorkbook.Path Dim Fol As String Dim Fname As String Dim Ws As Worksheet Fname = Dir("*.xls") Do While Fname <> "" If Fname <> ThisWorkbook.Name Then Workbooks.Open Fname For Each Ws In Worksheets Ws.PrintOut Next Workbooks(Fname).Close SaveChanges:=False End If Fname = Dir() Loop End Sub

noncha930

2019/05/14 04:15

現在このコードでうまく印刷ができています。【Sheet1】というシートのみ除外して印刷したい場合はどのようにコードを追記すればよろしいでしょうか。ご教授いただけると幸いです。

ttyp03

2019/05/14 04:19

この質問は完結していますので、マナー的にも新たに質問を作ってください。面倒とは思いますがよろしくお願いします。と思いましたが、直ぐに解決できそうなので回答しちゃいます。次からはお気をつけください。 PrintOutのところに条件をつけるとよいかと思います。 For Each Ws In Worksheets If Ws.Name <> "Sheet1" Then Ws.PrintOut End If Next

noncha930

2019/05/14 05:35

ルールをよく知らずすみませんでした。次からそのようにいたします＞＜コードを記載してみたのですが「オブジェクトが必要です」とエラーになってしまいます。。入れ込む部分を間違えているでしょうか？ Sub 一括印刷() ChDir ThisWorkbook.Path Dim Fol As String Dim Fname As String Dim Ws As Worksheet Fname = Dir("*.xls") If sh.Name = "sheet1" Then Do While Fname <> "" If Fname <> ThisWorkbook.Name Then Workbooks.Open Fname For Each Ws In Worksheets If Ws.Name <> "Sheet1" Then Ws.PrintOut End If Next Ws.PrintOut Workbooks(Fname).Close SaveChanges:=False End If Fname = Dir() Loop End If End Sub

ttyp03

2019/05/14 05:38

Nextの次行に余計なWs.PrintOut行がありますね。この行は削除してください。

noncha930

2019/05/15 05:54

Sub 一括印刷() ChDir ThisWorkbook.Path Dim Fol As String Dim Fname As String Dim Ws As Worksheet Fname = Dir("*.xls") If sh.Name = "sheet1" Then Do While Fname <> "" If Fname <> ThisWorkbook.Name Then Workbooks.Open Fname For Each Ws In Worksheets If Ws.Name <> "Sheet1" Then Ws.PrintOut End If Next Workbooks(Fname).Close SaveChanges:=False End If Fname = Dir() Loop End If End Sub

noncha930

2019/05/15 05:55

削除したのですが上記と同様のエラーが出てしまいます。。どこがおかしいか教えていただけますでしょうか。何度も申し訳ありません。

noncha930

2019/05/15 05:56

除外したいシート名（Sheet1）は存在しています。ちなみにSheet1が存在しないエクセルの場合はエラーになってしまいますでしょうか？

ttyp03

2019/05/15 06:01

Do While の前にIf文が増えてますね。

noncha930

2019/05/15 06:12

できました（：；）本当にありがとうございます！次からは新しい質問をたてます。ありがとうございました＾＾