Excel-VBA zu langsam
06.04.2016 10:19:56
Matthias
ich versuche aktuell ein Archiv mit verschiedenen Dateitypen (ca. 700GB) automatisch auszulesen.
Das Exceltool arbeitet leider extrem langsam und hängt sich durch die Menge irgendwann auf.
Sind in meinem Code Stellen vorhanden welche viel Rechenkraft benötigen und kann ich diese besser gestalten? (Bis jetzt habe ich auf Geschwindigkeit nie geachtet, da ich nur mit kleineren Mengen gearbeitet habe)
Arbeitsablauf:
1. Alle Dateien in Ordnerstruktur finden
2. Alle Dateien prüfen (Ist es eine xls / handelt es sich um den gesuchten Exceltabellentyp [Kalkulationstool] / Handelt es sich um einen bestimtmen Typ von kalkulation)(Ja -> 3. / Nein -> 4.)
3. Kopiervorgänge
4. Nächste Datei
Zum Übertragen der Daten verwende ich die GetInfoFromClosedFile-Funktion.
Sub Schaltfläche1_Klicken()
Cells(2, 1) = Now
schleifendurchlauf = 0
Dim fso, oFolder, oSubfolder, oFile, queue As Collection, counter As Double, dateiname As _
_
_
_
_
String, sheetnr As String, LReturnValue As Boolean, whatProcess As Double
On Error Resume Next
counter = 3
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(ThisWorkbook.Path)
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
'Test ob Excel-Tabellen
If Right(oFile, 4) = ".xls" Then
dateiname = Right(oFile, InStr(1, StrReverse(oFile), "\") - 1) 'Dateiname _
_
_
aus oFile extrahiert
testx = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage", "B5")
If Not testx = "Vertrieb-ID:" Then GoTo ende 'Test ob _
Kalkulationstool
For i = 0 To 9
sheetnr = "F0" & i
If Not GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "K38") > 0 Then _
_
_
GoTo endei 'Raus wenn keine Kosten
If GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "H206") = "Ja" Then _
_
_
GoTo endei 'Raus wenn Kleben enthalten
punkt = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "D243")
'Menge an Schweißpunkten
buckel = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "H243")
'Menge an Buckelschweißen
mag = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "D218")
'Menge an MAG-Naht
whatProcess = punkt + buckel + mag
'Prüfung on nur ein Fügeverfahren (Kombinationen sind nicht erwünscht)
If whatProcess = 0 Then GoTo endei
If whatProcess = punkt Or whatProcess = buckel Or whatProcess = mag
'Hier beginnen die Kopiervorgänge
Then Cells(counter, 1) = Now _
Cells(counter, 2) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage", "H5") 'Anfragenr.
Cells(counter, 3) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "
K38") 'Fügekosten
Cells(counter, 4) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "
D243") 'Schweißpunkte
Cells(counter, 5) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "
H243") 'Buckelschweißen
Cells(counter, 6) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "
D218") 'Nahtlänge
Cells(counter, 7) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr, "
K17") 'TeileProZyklus
Cells(counter, 8) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage",
"D9") 'Kunde
Cells(counter, 9) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage",
"K5") 'Datum
Cells(counter, 10) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "I19") 'LaufzeitIntern
Cells(counter, 12) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "D30") 'Jahr1
Cells(counter, 13) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "E30") 'Jahr2
Cells(counter, 14) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "F30") 'Jahr3
Cells(counter, 15) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "G30") 'Jahr4
Cells(counter, 16) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "H30") 'Jahr5
Cells(counter, 17) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "I30") 'Jahr6
Cells(counter, 18) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "J30") 'Jahr7
Cells(counter, 19) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "K30") 'Jahr8
Cells(counter, 20) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "D34") 'Jahr9
Cells(counter, 21) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "E34") 'Jahr10
Cells(counter, 22) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "F34") 'Jahr11
Cells(counter, 23) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "G34") 'Jahr12
Cells(counter, 24) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "H34") 'Jahr13
Cells(counter, 25) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "I34") 'Jahr14
Cells(counter, 26) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "J34") 'Jahr15
Cells(counter, 27) = GetInfoFromClosedFile(oFolder, dateiname, "Anfrage"
, "K34") 'Jahr16
Cells(counter, 11) = WorksheetFunction.Sum(Range(Cells(counter, 12),
Cells(counter, 27)))
'Gesamtstückzahl
Cells(counter, 29) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr,
"G19")
'Beschreibung
Cells(counter, 30) = GetInfoFromClosedFile(oFolder, dateiname, sheetnr,
"E50")
counter = counter + 1 'Zeilennummer in Zieltabelle hochzählen
End If
endei:
Next i
End If
ende:
Next oFile
Loop
End Sub
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) "\" Then wbPath = wbPath & "\"
If Dir(wbPath & "\" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function