| |
お世話になります。t.vと申します
自分の前任者が作成したマクロの改修を依頼されまして、改修するマクロは、
【対象フォルダに格納されているexcelファイルを全て印刷する】です。
細かい処理でプリンタ仕様で99ファイルで一旦ストップしたり、印刷するファイル名の書き出し等がありますが、
今回改修したい部分は【excelファイル】→【全ファイル】に改修する予定です。
当方、VBAは勉強中の身で処理内容がほぼ解らず対応方法が解りません。
ファイル拡張子部分を追加したりしたのですがどうにもうまくいきませんでした。
どうかご教授願います。
現在使用してるマクロを以下に記載しますが、全く別のマクロを提示頂いて構いません。
一番の目的は【対象フォルダ内のファイルを全て（txt,excel,word,pdf）印刷する】です。
*----------------------------------------*
Sub 指定ドライブのファイルの一覧を作成する()
Application.ScreenUpdating = False
Dim xxx As Range
Dim FSO As Object
Dim fol As Object
Dim Fil As Object
Dim FileBuf As Object
Dim Subfol As Object
Dim SubFil As Object
Dim SubFolderBuf As Object
Dim count As Integer
Dim PrintFlag As Boolean
PrintFlag = False
Const c_div_cnt As Integer = 99 '処理分割単位（ファイル数）
Dim print_cnt As Integer '印刷済みファイル数カウンタ
Dim total_print As Integer '印刷済みファイル総数
Set xxx = Worksheets("Sheet1").Range("b2")
print_cnt = 0
total_print = 0
Worksheets("Sheet1").Activate
Range("A:A").ClearContents 'クリアする
Set FSO = CreateObject("Scripting.FileSystemObject") 'ファイルシステムオブジェクトのインスタンス化
On Error Resume Next
Set fol = FSO.Getfolder(xxx) 'フォルダを取得
Set Fil = fol.Files 'ファイルを取得
Set Subfol = Nothing 'サブフォルダを検索
Set Subfol = FSO.Getfolder(xxx).SubFolders 'サブフォルダを取得
On Error GoTo 0
'もし、ファイルがフォルダ内に見つからない場合、何もしない
If fol.Files.count = 0 Then
Else
count = 1
For Each FileBuf In Fil
If (Right(Dir(FileBuf.Path), 4) = ".xls") Or (Right(Dir(FileBuf.Path), 4) = "xlsx") Or (Right(Dir(FileBuf.Path), 4) = "xlsm") Then
PrintFlag = True 'ひとつでもxlsファイルが見つかった場合に、PrintFlagをTrueにする
Cells(count, 1) = FileBuf.Path
count = count + 1
End If
Next
End If
'もし、サブフォルダがフォルダ内に見つからない場合、何もしない
If Subfol Is Nothing Then
Else
For Each SubFolderBuf In Subfol
Call Loop_LISTUP(SubFolderBuf.Path, count, PrintFlag)
Next
End If
Application.ScreenUpdating = True
If PrintFlag Then
If vbCancel = MsgBox("全部で" & (count - 1) & "ファイルを印刷します", vbOKCancel) Then
Exit Sub
End If
If c_div_cnt < (count - 1) Then
MsgBox c_div_cnt & "ファイルを印刷する毎に処理を一旦停止します", vbOKOnly
End If
For n = 2 To count
Workbooks.Open Worksheets("Sheet1").Cells(n - 1, 1).Value
Worksheets(1).PageSetup.LeftHeader = "&F"
ActiveWorkbook.PrintOut Copies:=1, Collate:=True
Worksheets(1).Activate
ActiveWindow.Close False
print_cnt = print_cnt + 1
If c_div_cnt = print_cnt Then
'印刷済数カウントアップ
total_print = total_print + print_cnt
'カウンタクリア
print_cnt = 0
If 0 < (count - 1) - total_print Then
If vbCancel = MsgBox("残り" & (count - 1) - total_print & "ファイルです。" & Chr(13) & Chr(10) & _
"プリンタ出力を完了させてからOKを押してください", vbOKCancel) Then
Exit Sub
End If
End If
End If
Next
End If
Application.ScreenUpdating = True
' Cells(1, 結果).Clear 'クリアする
End Sub
Private Sub CommandButton1_Click()
Call 指定ドライブのファイルの一覧を作成する
End Sub
Sub Loop_LISTUP(ByVal target As String, ByRef count As Integer, ByRef PF As Boolean)
Dim FSO As Object
Dim fol As Object
Dim Fil As Object
Dim FileBuf As Object
Dim Subfol As Object
Dim SubFil As Object
Dim SubFolderBuf As Object
Worksheets("Sheet1").Activate
Set FSO = CreateObject("Scripting.FileSystemObject") 'ファイルシステムオブジェクトのインスタンス化
On Error Resume Next
Set fol = FSO.Getfolder(target) 'フォルダを取得
Set Fil = fol.Files 'ファイルを取得
Set Subfol = Nothing
Set Subfol = FSO.Getfolder(target).SubFolders 'サブフォルダを取得
On Error GoTo 0
'もし、ファイルがフォルダ内に見つからない場合、何もしない
If fol.Files.count = 0 Then
Else
For Each FileBuf In Fil
If (Right(Dir(FileBuf.Path), 4) = ".xls") Or (Right(Dir(FileBuf.Path), 4) = "xlsx") Or (Right(Dir(FileBuf.Path), 4) = "xlsm") Then
PF = True 'ひとつでもxlsファイルが見つかった場合に、PFをTrueにする
Cells(count, 1) = FileBuf.Path
count = count + 1
End If
Next
End If
'もし、サブフォルダがフォルダ内に見つからない場合、何もしない
If Subfol Is Nothing Then
Else
For Each SubFolderBuf In Subfol
Call Loop_LISTUP(SubFolderBuf.Path, count, PF)
Next
End If
End Sub
*----------------------------------------*
|
|
t.v
- 14/4/22(火) 16:21 -
