Alle Dateien in einem Ordner öffnen und Code ausfü

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Alle Dateien in einem Ordner öffnen und Code ausfü
von: pH
Geschrieben am: 20.05.2015 09:49:01

Hallo zusammen,
ich habe ein kleines Problemchen, bei dem ich ohne eure Hilfe wohl nicht weiterkomme.
Ich möchte aus einem separaten File heraus alle .XLSM-Dateien im gleichen Verzeichnis öffnen, einen bestimmten Code ausführen und die ganze Geschichte wieder schließen.
So weit, so gut. In den Tiefen des Internets habe ich nun folgenden Code gefunden, der mit verschiedenen Codes / Makros eigentlich auch macht, was er soll:
Option Explicit
Const strPath As String = "C:\Test\"
Sub Main()
Dim strDateiname As String
Dim wkbBook As Workbook
Dim lngLastRowQ As Long
Dim lngLastRowZ As Long
Dim lngLastCol As Long
Dim intCalc As Integer
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'strDateiname = Dir$(ThisWorkbook.Path & "\*.xls")
strDateiname = Dir$(strPath & "*.xlsm")
Do While strDateiname <> ""
If strDateiname <> ThisWorkbook.Name Then
Set wkbBook = Workbooks.Open(strPath & strDateiname)
' Hier jetzt Dein Code!!!
wkbBook.Close False ' Oder True, wenn gespeichert werden soll
Set wkbBook = Nothing
End If
strDateiname = Dir$()
Loop
Fin:
Set wkbBook = Nothing
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Nun hat mir in einem Forum ein netter Kollege vor ein paar Monaten folgenden Code gestrickt, um sämtliche Daten eines Files wochenweise auszudrucken:
Sub Wochenbelege_Drucken()
Dim colKWJahr As Collection
Dim varKWJahr As Variant

Dim lngKW As Long
Dim lngJahr As Long

Application.ScreenUpdating = False

With Tabelle1

.PageSetup.PrintTitleRows = "$1:$1"

If .AutoFilterMode Then .AutoFilterMode = False

With .Range("A1").CurrentRegion

Set colKWJahr = getKW_Jahr_Unikate(.Columns(13).Resize(, 2).Offset(1))

For Each varKWJahr In colKWJahr
lngKW = varKWJahr(0)
lngJahr = varKWJahr(1)

.AutoFilter Field:=13, Criteria1:=lngKW
.AutoFilter Field:=14, Criteria1:=lngJahr

' Drucken
.Worksheet.AutoFilter.Range.PrintOut 1, , 1

' PDF-Ausgabe
' .Worksheet.AutoFilter.Range.ExportAsFixedFormat _
' Type:=xlTypePDF, _
' Filename:=ThisWorkbook.Path & "\" & lngJahr & "_" & Format(lngKW, "00") & " " & Replace(ThisWorkbook.Name, ".xlsm", ".pdf"), _
' Quality:=xlQualityStandard, _
' IncludeDocProperties:=True, _
' IgnorePrintAreas:=False, _
' OpenAfterPublish:=False

.AutoFilter Field:=13
.AutoFilter Field:=14
Next

Set colKWJahr = Nothing

End With

.AutoFilterMode = False

End With
End Sub

Private Function getKW_Jahr_Unikate(Bereich As Range) As Collection
    Dim avarDaten As Variant
    Dim lngIndexD As Long
    Dim lngKW As Long
    Dim lngJahr As Long
    
    avarDaten = Bereich.Value
    
    Set getKW_Jahr_Unikate = New Collection
    
    On Error Resume Next
    For lngIndexD = LBound(avarDaten) To UBound(avarDaten)
        If Not IsEmpty(avarDaten(lngIndexD, 1)) Then
        If Not IsEmpty(avarDaten(lngIndexD, 2)) Then
            lngKW = CLng(avarDaten(lngIndexD, 1))
            lngJahr = CLng(avarDaten(lngIndexD, 2))
            getKW_Jahr_Unikate.Add Array(lngKW, lngJahr), lngKW & "_" & lngJahr
        End If
        End If
    Next
    
End Function

Auch dieser Code funktioniert, für sich genommen, ausgezeichnet.
Ich wollte mir nun ein wenig Arbeit ersparen und eben dieses Drucken für jede Excel-Datei in C:\Test\ automatisch durchführen.
Ich weiß nun allerdings nicht, wie ich beide Codes so kombinieren kann, dass Excel auch tut, was ich von ihm möchte.
Da alle Versuche, die beiden Codes zu kombinieren, scheiterten und diverse Fehler ausgaben, habe ich probiert, ein Modul in Personal.XLSB anzulegen und dieses aufzurufen.
Hierzu habe ich an der Stelle "'Hier jetzt dein Code" die folgende Zeile eingebaut:
Application.Run ("Personal.xlsb!Wochenbelege_Drucken")
Excel beginnt auch zu arbeiten und stürzt nach einiger Zeit ab. Andere Makros wiederum funktionieren.
Ich habe dann einige Zeit bei Google verbracht und schließlich vermutet, dass ich Excel vielleicht ein wenig mehr Zeit zum arbeiten geben muss. Letztendlich kam dabei dann folgendes heraus:
Application.Run ("Personal.xlsb!Register_Drucken")
Application.Wait Now + TimeSerial(0, 0, 15)
Leider führt dies immer noch zu einem Excel-Absturz und auch dazu, dass mir langsam die Ideen ausgehen.
Könnte mir vielleicht jemand von den Experten hier weiterhelfen?
Schon mal vielen Dank im Voraus!!!
Schöne Grüße
pH

Bild

Betrifft: AW: Alle Dateien in einem Ordner öffnen und Code ausfü
von: pH
Geschrieben am: 20.05.2015 10:12:27
Hallo noch mal,
ich habe leider gerade erst gelesen, dass Nicks hier nicht unbedingt erwünscht sind.
Leider habe ich nicht herausgefunden, wie ich meinen ersten Beitrag noch editieren könnte.
Sorry dafür!
Ich werde mich zukünftig natürlich an eure Gepflogenheiten halten.
Schöne Grüße
Mike

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Alle Dateien in einem Ordner öffnen und Code ausfü"