Alle (eingeblendeten) Sheets auswählen und drucken

Sub Drucken() Dateiname = Dir$("C:\PS\2006\08\\*.xls") Do While Dateiname <> "" Workbooks.Open "C:\PS\2006\08\" & Dateiname, False FEHLT: ALLE TABELLEN AUSWÄHLEN FEHLT ALLE AUSGEWAEHLTEN TABELLEN DRUCKEN ActiveWorkbook.Close False Dateiname = Dir$() Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
folgendes nach dem Öffnen des Workbooks ergänzen:


Sub Drucken_1()
Dim SH As Worksheet
For Each SH In ActiveWorkbook.Worksheets
SH.Select (0)
Next
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub

Im Prinzip könntest du auch jedes Sheet einzeln drucken:
Public


Sub Drucken_2()
Dim SH as worksheet
For Each SH In ActiveWorkbook.Worksheets
SH.Printout
next
End Sub

Der Unterschied zwischen beiden Varianten tritt dann zutage, wenn Seitennummern in Kopf- oder Fußzeile verwendet werden.
Im ersten Fall werden die Seitennummern bei den Sheets weiter hochgezählt und nur bei einem neuen Workbook wird wieder mit 1 begonnen,
im 2. Fall wird bei jedem Sheet wieder mit 1 begonnen.
Welche Variante du wählst, solltest du davon abhängig machen, wie du deine Seitennummerierung gestalten willst.
Ähnlich sieht es aus wenn du die Möglichkeit hast und nutzt, beim Drucken gleich PDFs zu erzeugen.
Bei Variante 1 kommen alle Sheets eines Workbooks in ein PDF-File, bei der 2. Variante wird für jedes Sheet ein eigenes PDF erzeugt.
daher macht die Variante, die Sheets erst zu selektien und dann zu drucken durchaus Sinn.
Gruß, Daniel

Hallo Peter!
Das sollte deine Wünsche erfüllen.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Drucken()
Dim xlApp As Application
Dim objFS As FileSearch
Dim objWB As Workbook
Dim objWS As Worksheet
Dim strPath As String
Dim intIndex As Integer, intC As Integer
Dim arrSheets() As Variant

strPath = fncBrowseForFolder("F:\temp") 'Optional Standardordner übergeben!

If strPath = "" Then Exit Sub

Set objFS = Application.FileSearch

With objFS
  .NewSearch
  .LookIn = strPath
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = False ' Unterordner /Ja/Nein

  If .Execute > 0 Then

    Set xlApp = CreateObject("Excel.Application")

    xlApp.Visible = False

    For intIndex = 1 To .FoundFiles.Count

      intC = 0

      Set objWB = xlApp.Workbooks.Open(.FoundFiles(intIndex))

      For Each objWS In objWB.Worksheets

        If objWS.Visible Then
          Redim Preserve arrSheets(intC)
          arrSheets(intC) = objWS.Name
          intC = intC + 1
        End If

      Next

      objWB.Sheets(arrSheets).PrintOut

      Erase arrSheets

      objWB.Close False

      Set objWB = Nothing

    Next

    xlApp.Quit

    Set xlApp = Nothing

  End If

End With

Set objFS = Nothing

End Sub

Private Function fncBrowseForFolder(Optional defaultPath As Variant = "C:\") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object

Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)

If objFlder Is Nothing Then GoTo ErrExit

Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path

ErrExit:

Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Alle (eingeblendeten) Sheets auswählen und drucken

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread