Array - pdf-Ordner einlesen / Tempo
20.05.2009 10:51:28
Florian
Ich habe eine Makro, die ca. 1000 xls-Dateine (eine Artikelnummer = 1 Datei) öffnet und (u.a.) die Existenz diverser Dokumente je Artikelnummer prüft. Die Dokumente liegen als pdf in einem Ordner, jedes pdf trägt dabei Artikelnummer im Namen. Der Abgleich (mit Ranges, also Info, ob pdf existiert, steht in Worksheet) funktioniert ohne Probleme, aber: ich möchte den ganzen Ablauf so schnell wie mölich machen ==> Arrays.
Frage nun: kann ich den "Umweg" über Worksheet umgehen und gleich pdf-Dateiname/Pfad in Array schreiben? Funktionieren denn bei einem Array Funktionen wie etwa die "Left"-Funktion (ich hatte da ne Fehlermeldung). Oder würde es den Ablauf bereits genug beschleunigen, wenn ich indirekt vorgehe, also zuerst alles in ein Sheet importiere, dann vom Sheet in Array, das Sheet schliesse und den eigentlichen Abgleich der 1000 Dateien nur mit dem Array mache?
Anbei der prinzipielle Code. Danke Euch schon mal im Voraus!
Florian
Sub Lies_PDF_In_Array()
Set SteuerDatei = ThisWorkbook
MyPath = SteuerDatei.Path
Workbooks.Add
Set BB740_Datei = Workbooks(Workbooks.Count)
Worksheets(3).Delete
Worksheets(2).Delete
BB740_Datei.Sheets(1).Name = "KdeSkjem"
Set KdeSkjemSheet = BB740_Datei.Sheets("KdeSkjem")
' Einlesen der pdfs in eine Range
Set FsoPdf = CreateObject("Scripting.FileSystemObject")
For Each oPDF_File In FsoPdf.getfolder("\\*****PFAD****").Files
If LCase(Right(oPDF_File.Name, 4)) = ".pdf" Then
LastRowKdeSkjem = KdeSkjemSheet.Cells(Rows.Count, 1).End(xlUp).Row - Not IsEmpty( _
KdeSkjemSheet.Cells(Rows.Count, 1).End(xlUp))
KdeSkjemSheet.Cells(LastRowKdeSkjem, 1) = Left(oPDF_File.Name, 5)
KdeSkjemSheet.Cells(LastRowKdeSkjem, 2) = "\\*****PFAD****\" & oPDF_File.Name
End If
Next oPDF_File
' Einlesen der Range in Array
ReDim KdeSkjemArr(1 To LastRowKdeSkjem, 1 To 2)
For iArr = 1 To LastRowKdeSkjem
KdeSkjemArr(iArr, 1) = KdeSkjemSheet.Cells(iArr, 1)
KdeSkjemArr(iArr, 2) = KdeSkjemSheet.Cells(iArr, 2)
Next iArr
' Kontrolle: Übergabe der Array-Daten an Range
For iArr = 1 To LastRowKdeSkjem
KdeSkjemSheet.Cells(iArr, 4) = KdeSkjemArr(iArr, 1)
KdeSkjemSheet.Cells(iArr, 5) = KdeSkjemArr(iArr, 2)
Next iArr
BB740_Datei.SaveAs Filename:=MyPath & "\Sammelfiler\BB740.xls"
BB740_Datei.Close Savechanges:=True
End Sub