Makro einfügen

Sub AlleDrucken() Dim iCounter As Integer Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo ERRORHANDLER With Application.FileSearch .LookIn = "O:\Formulare\Protokolle" .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks .Execute For iCounter = 1 To .FoundFiles.Count Workbooks.Open .FoundFiles(iCounter), False ActiveWorkbook.PrintOut ActiveWorkbook.Close savechanges:=False Next iCounter End With ERRORHANDLER: Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Makro einfügen

31.03.2021 10:09:21

Daniel

AW: Makro einfügen

31.03.2021 10:56:55

Timo

AW: Makro einfügen

31.03.2021 12:33:43

Werner

AW: Makro einfügen

31.03.2021 14:29:56

oraculix

AW: Makro einfügen

31.03.2021 16:37:19

Timo

AW: Makro einfügen

31.03.2021 17:39:09

Werner

AW: Makro einfügen

01.04.2021 14:08:27

Timo

Hallo,
nach langen suchen nach einer Alternative für Application.Filesearch hab ich einen anderen Code gefunden, der Funktioniert auch Super.

Sub AlleDruckenAnders()
Dim Ordner() As String, strDatNam As String
Dim i As Integer
'Stammverzeichnis:
Const strPfad As String = "C:\Users\sommer_t\Desktop\PQ Versuch"
'Alle Verzeichnisse in's Array:
Ordner = AlleUnterordner(strPfad)
'Schleife über alle Ordner
For i = 0 To UBound(Ordner)
'Schleife über alle Dateien:
strDatNam = Dir(Ordner(i) & "\*.xls*")
Do While strDatNam  ""
'Datei öffnen, drucken, schließen:
Workbooks.Open Ordner(i) & "\" & strDatNam, False
ActiveWorkbook.PrintOut
ActiveWorkbook.Close savechanges:=False
'nächster Dateiname
strDatNam = Dir()
Loop
Next
End Sub
Public Function AlleUnterordner(ByVal strPfad As String, Optional mitStammordner As Boolean =  _
True)
Dim StrTmp As String
If mitStammordner Then
StrTmp = strPfad & ","
End If
SubAlleUnterordner strPfad, StrTmp
AlleUnterordner = Split(Left(StrTmp, Len(StrTmp) - 1), ",")
End Function
Private Sub SubAlleUnterordner(ByVal strPfad As String, ByRef strAlle As String)
Dim fso As Object
Dim Ordner
Dim Unterordner
Set fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = fso.getfolder(strPfad)
On Error Resume Next
For Each Unterordner In Ordner.subfolders
strAlle = strAlle & Unterordner.Path & ","
SubAlleUnterordner Unterordner.Path, strAlle
Next
Set fso = Nothing
Set Ordner = Nothing
End Sub

Ich würde nur gerne den Pfad nicht direkt in den Code eingeben Sondern gerne auf dem Tabellenblatt in Zelle B1 eingeben, könnte mir da einer helfen bei den Änderungen?

Sub AlleDrucken() Dim strDir As String, objFSO As Object, objDir As Object Set objFSO = CreateObject("scripting.filesystemobject") strDir = ThisWorkbook.Worksheets("Tabelle1").Range("B1") Set objDir = objFSO.GetFolder(strDir) Dateienausgeben objDir Set objDir = Nothing: Set objFSO = Nothing End Sub

Sub Dateienausgeben(ByVal Ordner As Object) Dim DatOrd As Variant, Datei As Object For Each Datei In Ordner.Files If Right(Datei.Name, 4) Like "xls*" Then Workbooks.Open Ordner & "\" & Datei.Name, False ActiveWorkbook.PrintPreview ActiveWorkbook.Close False End If Next For Each DatOrd In Ordner.SubFolders For Each Datei In DatOrd.Files If Right(Datei.Name, 4) Like "xls*" Then Workbooks.Open DatOrd & "\" & Datei.Name, False ActiveWorkbook.PrintPreview ActiveWorkbook.Close False End If Next Next End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread