[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダの中にある複数のエクセルを一度に印刷したいのです。』（石田）
共有のネットワークで使っている"3階"というフォルダの中に、石田計画書.xls、井上計画書.xls、上田計画書.xls、江藤計画書.xls、・・・・和田計画書.xlsというエクセルをいれています。エクセルの数は40個ほどです。
○○計画書.xlsの中には、「メインメニュー」というシートと、「計画書」というシートの２つのシートがあります。
これらの"3階"というフォルダの中にある40個ほどのすべてのエクセル○○計画書.xlsの「計画書」のシートを一度に印刷をする方法はありますでしょうか。
（できれば、自動で実行し、その間、ＰＣから離れて、別の作業を行いたいので、ひとつのエクセルが立ち上がり→プリントアウト→保存しますか？→いいえ→エクセルを閉じる・・という部分の いいえ の人的な作業をさけたいのです。）
ご教示よろしくお願いいたします。（石田）
ネット上にツールがあると思いますが、 VBAで自作も可能です。
Dir関数でフォルダ内のブックを取得し、 ブックを開きシートを印刷、ブックを閉じる、 をループさせることになると思います。 (MARBIN)
フォルダ内のファイル一覧は↓が参考になります。
https://www.excel.studio-kazu.jp/mag2/backnumber/mm20041012.html
これはファイル名をセルに転記していますが、セルに転記する代わりに ファイル(ブック)を開いて、となります。 (MARBIN)
Sub FileListProc()
' ファイルの一覧を作成する
Dim r As Integer, c As Integer
Dim curpath As String, opt As String
curpath = Selection.Value
opt = Selection.Offset(0, 1).Value
If Len(curpath) > 1 Then
r = Selection.Row
c = Selection.Column
CurFileList r, c, curpath, opt
Else
MsgBox "フォルダのパスを入力したセルを選択してください。" & _
vbCrLf & "例) C:\Documents and Settings\kazu\My Documents"
End If
End Sub
Sub CurFileList(r, c, cur, opt)
' 指定されたパスのファイル一覧を取得
Dim cur2 As String, myfile As String
If Right(cur, 1) <> "\" Then
cur = cur & "\" ' パスの最後に\がない場合の対策
End If
cur2 = cur
If Len(opt) <> 0 Then
cur2 = cur2 & "*." & opt ' suffix の指定
End If
myfile = Dir(cur2, vbNormal) ' ←ポイント1
r = r + 1
Do While myfile <> Empty
Cells(r, c).Value = myfile
Cells(r, c + 1).Value = FileDateTime(cur & myfile) 'ファイルの更新日付
r = r + 1
myfile = Dir() ' ←ポイント2
Loop
End Sub
Sub FileListProc2()
' いつも決まったフォルダの一覧をいくつも作成する場合の例 ' CurFileList 101, 1, "C:\Documents and Settings\kazu\My Documents", "xls" ' CurFileList 2, 1, "C:\Windows", "" End Sub
（石田）
>共有のネットワークで使っている"3階"というフォルダの中
見落としてました。 印刷時に他の方がフォルダ内のブックを開いている可能性はありますか？ もし他の方がブックを開いていると、ブックを開くときにエラーになる 可能性があります。
また、このフォルダは移動する可能性はありますか？ もし、移動しないのなら、セルからフォルダのパスを取得しないで、 定数として指定することも出来ます。
指定フォルダ内のエクセルブックのみを取得すしセルに転記するサンプルです。
Sub test()
Const fol As String = "D:\marbin" 'フォルダを定数として指定
Dim f As String
Dim cnt As Integer
f = Dir(fol & "\*.xls") '指定フォルダ内のエクセルブック取得
Do While f <> "" 'ブックがなくなるまで
cnt = cnt + 1 'カウントアップ
Worksheets(1).Range("A" & cnt).Value = f 'セルに取得したブック名を転記
f = Dir()
Loop
End Sub
また、 Workbooks.Open(ブックのフルパス) '上の例では fol & "\" & f がフルパス でブックを開くことが出来ます。
これを Set wb = Workbooks.Open(ブックのフルパス) とすると、変数に格納されたブックを処理できます。
シートの指定は
Set ws = wb.Sheets("計画書")
などとします。
ws.PrintOut
でシートを印刷します。
次は、 wb.Close で開いたブックを閉じます。
まとめると、こんな感じです。
Sub test2()
Const fol As String = "\\Neccomputer\D\marbin"
Dim f As String
Dim cnt As Integer
Dim wb as Workbook
f = Dir(fol & "\*.xls")
Do While f <> ""
set wb = Workbooks.Open(fol & "\" & f)
wb.Sheets("計画書").PrinOut
wb.close
f = Dir()
Loop
set wb = Nothing
End Sub
(MARBIN)
D\ → D:\
でした。 (MARBIN)
\x{fffd}@このマクロを実行する時には、そのフォルダのなかのプログラムは誰も使用しない状況にしようと思っています。また、基本的にはフォルダの移動はありません。
\x{fffd}Aご作成いただきました、マクロを
\\Fssvr\書棚\c1-3分院リハビリ科\リハ計画・サマリー・患者管理\リハ計画書（リハ）
上記を記載したセルの上で実行したところ、
f = Dir(fol & "\*.xls") の部分で、「「実行時エラー'52':ファイル名または番号が不適切です」」とのえらメッセージが出ました。なにか問題なのでしょうか？
ご指導お願い致します。
Sub Macro2()
'
' Macro2 Macro
' マクロ記録日 : 2007/1/17 ユーザー名 : toriika
'
Const fol As String = "\\Neccomputer\D:\marbin"
Dim f As String
Dim cnt As Integer
Dim wb As Workbook
f = Dir(fol & "\*.xls")
Do While f <> ""
Set wb = Workbooks.Open(fol & "\" & f)
wb.Sheets("計画書").PrinOut
wb.Close
f = Dir()
Loop
Set wb = Nothing
End Sub
（石田）
>Const fol As String = "\\Neccomputer\D:\marbin" ここ、私のPCのパスのまんまですが・・・。 石田さんが実際に実行されたコードをアップしてみてください。 (MARBIN)
意味が分かりました。
私が提示したコードは、セルの値を参照しません。
>Const fol As String = "\\Neccomputer\D:\marbin"
↓のように書き換えてみてください。
Const fol As String = "\\Fssvr\書棚\c1-3分院リハビリ科\リハ計画・サマリー・患者管理\リハ計画書（リハ）" (MARBIN)
補足です。 ネットワーク越しの作業になりますので、印刷開始まで 若干時間がかかるかもしれません。 (MARBIN)
Const fol As String = "\\Fssvr\書棚\c1-3分院リハビリ科\リハ計画・サマリー・患者管理\リハ計画書（リハ）"
Dim f As String
Dim cnt As Integer
Dim wb As Workbook
f = Dir(fol & "\*.xls")
Do While f <> ""
Set wb = Workbooks.Open(fol & "\" & f)
wb.Sheets("計画書").PrinOut
wb.Close
f = Dir()
Loop
Set wb = Nothing
End Sub
で実行いたしましたところ、「実行時エラー’438’:オブジェクトはこのプロパティまたはメソッドをサポートしていません」とのエラーメッセージ。ディバックすると「 wb.Sheets("計画書").PrinOut」の部分で黄色の強調されました。
なにか問題なのでしょうか？ご指導お願い致します。
見よう見まねで、「wb.Sheets("計画書").PrinOut」の部分を⇒「Sheets("計画書").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True」との変更で、動かすことができました。
ただ、\x{fffd}@エクセルが開いて⇒\x{fffd}Aプリントアウト⇒\x{fffd}B保存せずに終了（選択肢として「いいえ」を選択）という、\x{fffd}Bの部分が手動になりました。MARBINさんのコードではこの部分は省略可能なのでしょうか？
以上2点についてご指導いただいてもよろしいでしょうか。
よろしくお願いいたします（石田）
プリンを出してました・・・。 PrinOut ↓ PrintOut と修正してください。 昨日から凡ミスばかり・・・。 失礼しました。 (MARBIN)
おそらく、 シートで Now などの揮発性関数を使っているか、 マクロでブック起動時にセルを操作する 作業を行っているのでしょう。
> Set wb = Workbooks.Open(fol & "\" & f)
> wb.Sheets("計画書").PrinOut
> wb.Close
↓のようにしてみてください。
Set wb = Workbooks.Open(fol & "\" & f)
wb.Sheets("計画書").PrintOut
wb.Close SaveChanges:=False
「SaveChanges:=False」を付加することで、編集を破棄します。
さらに、ブックの開閉を見せないようにするには、
Application.ScreenUpdating = False '画面の再描画停止
Set wb = Workbooks.Open(fol & "\" & f)
wb.Sheets("計画書").PrintOut
wb.Close SaveChanges:=False
Application.ScreenUpdating = True '画面の再描画再開
とします。 (MARBIN)
とりまとめをば・・・。
Sub test()
Const fol As String = "\\Fssvr\書棚\c1-3分院リハビリ科\リハ計画・サマリー・患者管理\リハ計画書（リハ）"
Dim f As String
Dim wb As Workbook
f = Dir(fol & "\*.xls") 'ファイル名の取り出し
Do While f <> "" 'ファイルがなくなるまで
Application.ScreenUpdating = False '画面の再描画停止
Set wb = Workbooks.Open(fol & "\" & f) 'ブックを開き変数wbにセット
wb.Sheets("計画書").PrintOut 'シートをプリントアウト
wb.Close SaveChanges:=False '編集を破棄してブックを閉じる
Application.ScreenUpdating = True '画面の再描画再開
f = Dir()
Loop
Set wb = Nothing '変数wbの開放
End Sub
(MARBIN)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.