Alle Dateien in einem Ordner öffnen und Code ausfü
20.05.2015 09:49:01
pH
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
.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