Mehrere Dateien ausdrucken

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Drucken() Const verz = "C:\" 'Pfad anpassen With Application.FileSearch .NewSearch .LookIn = verz .SearchSubFolders = True .Filename = "Tag*" & ".xls" 'was nur gedruckt werden soll .Execute End With For y = 1 To Application.FileSearch.FoundFiles.Count Set quelle = Workbooks.Open(Application.FileSearch.FoundFiles(y)) Worksheets(3).PrintOut Copies:=1, Collate:=True Next y End Sub

Sub Drucken() Const verz = "C:\" 'Pfad anpassen With Application.FileSearch .NewSearch .LookIn = verz .SearchSubFolders = True .Filename = "Tag*" & ".xls" 'was nur gedruckt werden soll .Execute End With For y = 1 To Application.FileSearch.FoundFiles.Count Set quelle = Workbooks.Open(Application.FileSearch.FoundFiles(y)) ActiveWorkbook.PrintOut From:=3, To:=3, Copies:=1, Collate:=True Next y End Sub

Hallo Martin!
Das sollte es tun!

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub OpenAndPrint()
Dim objWb As Workbook
Dim objSh As Worksheet
Dim objFS As FileSearch
Dim strPath As String
Dim intIndex As Integer
Dim oldStatus As Variant

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationManual
  .DisplayAlerts = False
  oldStatus = .StatusBar
End With

strPath = "F:\" 'Verzeichnis - Anpassen!

Set objFS = Application.FileSearch

With objFS
  .NewSearch
  .LookIn = strPath
  .SearchSubFolders = True
  .FileType = msoFileTypeExcelWorkbooks
  .Filename = "Tag*"

  If .Execute > 0 Then

    For intIndex = 1 To .FoundFiles.Count

      Set objWb = GetObject(.FoundFiles(intIndex))

      If Not objWb Is ThisWorkbook Then

        On Error Resume Next

        For Each objSh In objWb.Worksheets
          Application.StatusBar = "Drucke: " & .FoundFiles(intIndex) & " / Tabelle Nr.: " & objSh.Index
          objSh.PrintOut from:=3, to:=3
        Next

        On Error GoTo ErrExit

        objWb.Close False

      End If

      Set objWb = Nothing

    Next

  End If

End With

ErrExit:

Set objFS = Nothing

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlCalculationAutomatic
  .DisplayAlerts = True
  .StatusBar = oldStatus
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

92 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mehrere Dateien ausdrucken

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

92 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread