Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6832 / 76734 ←次へ | 前へ→

【75498】印刷用マクロについて
質問  t.v  - 14/4/22(火) 16:21 -

引用なし
パスワード
   お世話になります。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
*----------------------------------------*
6 hits

【75498】印刷用マクロについて t.v 14/4/22(火) 16:21 質問

6832 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free