Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1540to1544
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datein drucken

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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Warum …
17.02.2017 21:07:46
RPP63
… einfach, wenn es auch schwierig geht, Thomas?
Markiere die Dateien im Explorer, Rechtsklick, Drucken
Gruß Ralf
AW: Warum …
17.02.2017 21:33:58
Thomas
Hallo Ralf,
erstmal besten dank das du dir dies angeschaut hast.
Das Problem ist es sind imerca. 200 Datein sind und mit der explorer variante läuft es einfach nicht durch.
es werden manchmal 30 manchmal 40 Datein gedruckt und dann stürzt Excel oder windows einfach ab.
Diese Macro schafft es aber durchzulaufen.
Das Macro hatt auch noch den Vorteil das nur die Seiten gedruckt werden die auch ein Inhalt haben. Dauert zwar ein wenig länger aber das ist kein Problem.
Desweiteren bastle ich noch an einem zusatz zu diesem Macro das ich die fertig gedruckten datein noch in ein anderen Netzwerkordner kopieren muss. Dies geht zwar auch locker über den explorer aber so würde ich alles aus einer schaltzentrale machen können. Nur da bin ich noch nicht mit meinen eigenen recherchen fertig deshalb habe ich dies bis jetzt noch nicht erwähnt.
Geht es mit Excel das ich den derzeitigen Standertdrucker auslese Ihne dann mit dem Drückermenü verändere dann meine Datein drucke und zum schluss den alten Standartdrucker wieder einstelle?
hab recht vielen dank für dein interesse.
MFG Thomas
Anzeige
AW: Datein drucken
17.02.2017 21:23:47
littletramp
Hallo Thomas
Du hast den Block '### drucker aussuchen ja in der For Each objWorksheet In objWorkbook.Worksheets Schleife drin.
Gruss Markus
AW: Datein drucken
17.02.2017 22:30:14
Thomas
Hallo Markus,
ja ich weiss aber ich weis einfach nicht wie ich dies da rausbekomme.
MFG Thomas
AW: Datein drucken
17.02.2017 23:11:54
littletramp
Hallo Thomas
Hier der angepasste Code:
Zum Starten musst du nun Sub DateienDrucken() ausführen. Die Ordnerwahl habe ich in eine Funktion umgewandelt, die von Sub DateienDrucken() aufgerufen wird.
Option Explicit
Public Function Ordnerauswahl() As String
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
Ordnerauswahl = strOrdner   ' Rückgabewert festlegen
End Function
Sub DateienDrucken()
'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 = Ordnerauswahl     ' Ordnerwahl durch Benutzer
'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
'###  drucker aussuchen      !!!!!!!!!!!!! verschoben
Dim strPrinterName As String
Dim varRueckgabe As Variant
strPrinterName = Application.ActivePrinter
varRueckgabe = Application.Dialogs(xlDialogPrinterSetup).Show
If varRueckgabe = False Then Exit Sub
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
'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$
Loop
'Aktiver Drucker wieder erstellen     !!!!!!!!!!!!! verschoben
Application.ActivePrinter = strPrinterName
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
Gruss Markus
Anzeige
besten dank an littletramp
18.02.2017 07:29:19
Thomas
Hallo littletramp,
man ist das cool das klappt.
hab besten dank für deine viele arbeit. Es funktioniert richtig gut.
bin happy.
liebe grüsse thomas

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige