Datein drucken
17.02.2017 20:56:58
Thomas
Hallo Excelfreunde,
ich bin gerade dabei mir ein Macro zusammen zu basteln,
Es soll alle Exceldatein aus einem Ordner drucken.
Mit der unten beschriebenen Version scheint alles zu klappen. Das einzige was mir noch stört ist das ich bei jeder Datei den drucker bestätigen muss. kann sich dies mal jemand anschauen?
Vieleicht weiss jemand auch eine kürzere Variante.
Ich möchte gern den betroffenen Ordner und den jeweiligen Drucker aussuchen können.
Habt schon mal recht vielen dank für euer interesse.
liebe grüsse Thomas
Private Sub CommandButton1_Click()
'
Public Sub Ordnerauswahl()
'Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then MsgBox ("Kein Ordner gewählt!") Else MsgBox strOrdner
Call datein_drucken
End Sub
Sub datein_drucken()
'MsgBox "Sub1: " & strDateipfad
'alle Dateien eines Verzeichnisses mit allen Tabellen drucken
Dim strPath As String, strFileName As String
Dim objWorksheet As Worksheet, objWorkbook As Workbook
Dim lngColumn As Long, lngRow As Long
Dim lngLastColumn As Long, lngLastRow As Long
On Error GoTo err_exit
'Pfad anpassen
strPath = strOrdner '"C:\testordner\"
'prüfen ob der Pfad existiert
If Dir(strPath, vbDirectory) <> vbNullString Then
'ersten Dateinamen lesen
strFileName = Dir$(strPath & "*.xls*")
'prüfen ob eine Dateien vorhanden ist
If strFileName <> vbNullString Then
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.AskToUpdateLinks = False
End With
Do Until strFileName = vbNullString
'Datei öffnen
Set objWorkbook = Workbooks.Open(Filename:= _
strPath & strFileName, UpdateLinks:=0, ReadOnly:=True)
'Schleife über alle Tabellen
For Each objWorksheet In objWorkbook.Worksheets
With objWorksheet
'Suche letzte Zeile mit Inhalt
For lngColumn = .UsedRange.Columns.Count + .UsedRange.Column - 1 To 1 Step -1
lngLastRow = WorksheetFunction.Max(lngLastRow, .Cells(.Rows.Count, lngColumn).End(xlUp).Row)
Next
'Suche letzte Spalte mit Inhalt
For lngColumn = .UsedRange.Columns.Count + .UsedRange.Column - 1 To 1 Step -1
If .Cells(.Rows.Count, lngColumn).End(xlUp).Row > 1 Or .Cells(1, lngColumn).Value <> vbNullString Then
lngLastColumn = lngColumn
Exit For
End If
Next
'prüfen ob Tabelle nicht leer ist
If lngLastRow >= 1 And lngLastColumn >= 1 Then
'setze den Druckbereich
.PageSetup.PrintArea = "$A$1:" & .Cells(lngLastRow, lngLastColumn).Address
'### drucker aussuchen
Dim strPrinterName As String
Dim varRueckgabe As Variant
strPrinterName = Application.ActivePrinter
varRueckgabe = Application.Dialogs(xlDialogPrinterSetup).Show
If varRueckgabe = "Falsch" Then Exit Sub
' Hier den PrintOut befehl
'ActiveSheet.PrintOut
'########################################################################
'Drucke die Tabelle
objWorksheet.PrintOut
End If
lngLastColumn = 0
lngLastRow = 0
End With
Next
'Datei schließen
objWorkbook.Close SaveChanges:=False
next_file:
'nächsten Dateinamen holen
strFileName = Dir$
'drucker aussuchen
Application.ActivePrinter = strPrinterName
Loop
Set objWorkbook = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationAutomatic
.AskToUpdateLinks = True
End With
Else
MsgBox "Keine Dateien gefunden.", vbExclamation, "Abbruch"
End If
Else
MsgBox "Der Pfad '" & strPath & "' existiert nicht.", vbExclamation, "Abbruch"
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Programmfehler"
Resume next_file
End Sub