Supportnet / Forum / Tabellenkalkulation
Geschwindigkeitsvgl bei zwei Makros
Frage
Hi Leute,
ich habe eine Excel (Sammel-)Datei mit einem größeren Makro, die bzw. das ich hier auch schon mehrfach vorgestellt habe...
Mittlerweile bin ich nahezu fertig, das Makro führt folgende Schritte durch:
- Es fragt den User, wo es nach xls-Dateien suchen soll
- Sucht im Ordner und deren Unterordnern nach xls-Dateien
- Kopiert einen bestimmten Bereich aus diesen Dateien in die eigene (Sammel-)Datei
- Wertet die Werte in der Sammeldatei aus (MIN, MAX, STABW, HÄUFIGKEIT, ...)
das klappt auch alles eigentlich ganz gut...
jedoch habe ich hier zwei unterschiedliche Versionen des Makros...
- Makro #1 brauch für 1200 Dateien ca. 12-13s
- Makro #2 brauch für 1200 Dateien ca. 7-8s (aber hier funktioniert die Häufigkeitsverteilung nicht Very Happy)
Hier mal die Makros:
Makro#1:
Code:
[code]Option Explicit ' Sammelprotokoll Makro
Sub daten_uebernehmen()
Application.Calculation = xlManual
Application.EnableEvents = False / True
Dim Counter As Long
Dim h As Long
Dim i As Integer
Dim strFile As String
Dim strPath As String
Dim strDate As String
Dim loZeileZielmappe As Long
Dim inSpalte As Integer
Dim loZeileQuellmappe As Long
Dim ZielDatumZeile As Long
Dim ZielDateinameZeile As Long
Dim ZielDatumSpalte As Long
Dim loZaehler As Long
Dim myDefaultPath As Variant
Dim intCounter As Integer
myDefaultPath = ""
strPath = GetFolder(myDefaultPath, "Ordner auswählen...")
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
loZeileZielmappe = 6
loZaehler = 6
ZielDatumZeile = 6
ZielDateinameZeile = 7
ZielDatumSpalte = 1
Counter = 0
i = 6
With Application.FileSearch
.LookIn = strPath
.SearchSubFolders = True
.NewSearch
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute(SortBy:=msoSortByFileName) > 0 Then '(SortBy:=msoSortByFileDate, _SortOrder:=msoSortOrderAscending)
For h = 1 To .FoundFiles.Count
SplitPath .FoundFiles(h), strPath, strFile
If strFile <> ThisWorkbook.Name Then
Range(Cells(loZaehler, 2), Cells(loZaehler + 24, 7)).Formula = _
"='" & strPath & "[" & strFile & "]" & "Tabelle1'!B8"
Cells(ZielDatumZeile, ZielDatumSpalte).Formula = "='" & strPath & "[" & strFile & "]" & "tabelle1" & "'!A33"
Cells(ZielDatumZeile, ZielDatumSpalte).Copy
Cells(ZielDatumZeile, ZielDatumSpalte).PasteSpecial Paste:=xlPasteValues
Cells(ZielDateinameZeile, ZielDatumSpalte) = strFile
End If
For intCounter = 1 To 25
Cells(i, 8).Formula = Application.WorksheetFunction.Average(Worksheets("Tabelle1").Range("B" & i & ":F" & i))
i = i + 1
Next
i = i + 2
loZaehler = loZaehler + 27
ZielDatumZeile = ZielDatumZeile + 27
ZielDateinameZeile = ZielDateinameZeile + 27
loZeileZielmappe = loZaehler
' strFile = Dir()
Counter = Counter + 125
Next
End If
End With
Range("B6:G" & loZeileZielmappe).Copy
Range("B6:G" & loZeileZielmappe).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
Range("L7") = Counter
Range("K13") = Counter / 5
' Platzhalter
Range("H4") = Now()
Application.Calculation = xlAutomatic
End Sub
Private Function GetFolder(Optional ByVal varDefDir As Variant = "", Optional ByVal strTitle As String = "")
Dim objShell As Object, objFolder As Object
GetFolder = ""
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0&, strTitle, 0&, varDefDir)
If Not objFolder Is Nothing Then GetFolder = objFolder.Self.Path
Set objFolder = Nothing
Set objShell = Nothing
Range("h3") = Now()
End Function
Private Function SplitPath(ByVal strFullName As String, _
ByRef strPath As String, ByRef strName As String) As Boolean
Dim intPos As Integer
intPos = InStrRev(strFullName, "\")
If intPos > 0 Then
strPath = Left(strFullName, intPos)
strName = Mid(strFullName, intPos + 1)
Else
strPath = ""
strName = strFullName
End If
SplitPath = intPos > 0
End Function[/code]
... => geht weiter im ersten Posting !
Antwort 1 von sockly
...
Makro #2:
Code:
... 12-13s wären ja prinzipiell ganz ok... doch die Schwankungen bei Makro#1 sind tw. sehr extrem... manchmal braucht es auch für den gleichen Datensatz 30-35s !
=> nun kommt das eigentlich ärgerliche:
Die Dateien liegen im Netzwerk... die von mir hier angegebenen Zeitmessungen waren sind aber alle mit Dateien, die auch lokal auf dem PC verfügbar waren, durchgeführt worden...
Dadurch, dass die Dateien im Netzwerk liegen, verlangsamt sich der Vorgang nochmals auf ca. 3-4min !
Und hier ist Makro #2 bis zu 1min schneller als Makro #1 !
Ich habe mich hier im Board einige Zeit lang mit Makrobeschleunigung beschäftigt und immer wieder viel das Wort Array !
Doch ich bin ehrlich: Bei Arrays haben schon in der Schule meine Programmierkünste versagt Laughing
Meine Fragen:
1) Warum ist Makro #2 schneller ?
2) Würden hier Arrays den Ablauf beschleunigen ?
3) Wie baue ich hier ein Array ein (Arraytechnisch bin ich keine 0, sondern eine -15) ?
4) Gibt es sonst noch Möglichkeiten, den Ablauf zu beschleunigen ?
Ich bedanke mich bei euch für eure Hilfe und dafür, dass ihr euch mit meinem miserabel gecodeten Makro rumquält ^^
Greets und danke für die Hilfe,
sockly
P.S.
Ich habe mich schonmal an Arrays versucht....
Diese Zeilen kam dabei raus:
Makro #2:
Code:
Option Explicit
Sub daten_uebernehmen()
Application.Calculation = xlManual
Application.EnableEvents = False / True
Dim Counter As Long
Dim Addition As Long
Dim avg As Long
Dim h As Long
Dim i As Integer
Dim j As Integer
Dim strFile As String
Dim strPath As String
Dim loZeileZielmappe As Long
Dim inSpalte As Integer
Dim loZeileQuellmappe As Long
Dim ZielDatumZeile As Long
Dim ZielDateinameZeile As Long
Dim Datum As String
Dim ZielDatumSpalte As Long
Dim loZaehler As Long
Dim myDefaultPath As Variant
Dim intCounter As Integer
myDefaultPath = ""
strPath = GetFolder(myDefaultPath, "Ordner auswählen...")
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
loZeileZielmappe = 6
loZaehler = 6
ZielDatumZeile = 5
ZielDateinameZeile = 6
ZielDatumSpalte = 1
Counter = 0
i = 6
With Application.FileSearch
.LookIn = strPath
.SearchSubFolders = True
.NewSearch
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For h = 1 To .FoundFiles.Count
SplitPath .FoundFiles(h), strPath, strFile
' Debug.Print .FoundFiles(i), strPath, strFile
If strFile <> ThisWorkbook.Name Then
Range(Cells(loZaehler, 2), Cells(loZaehler + 24, 7)).Formula = _
"='" & strPath & "[" & strFile & "]" & "Tabelle1'!B8"
Cells(ZielDatumZeile, ZielDatumSpalte).Formula = "='" & strPath & "[" & strFile & "]" & "tabelle1" & "'!A33"
Cells(ZielDateinameZeile, ZielDatumSpalte) = strFile
End If
For intCounter = 1 To 25
Cells(i, 8) = (Cells(i, 2) + Cells(i, 3) + Cells(i, 4) + Cells(i, 5) + Cells(i, 6)) / 5
i = i + 1
Next
i = i + 2
loZaehler = loZaehler + 27
ZielDatumZeile = ZielDatumZeile + 27
ZielDateinameZeile = ZielDateinameZeile + 27
loZeileZielmappe = loZaehler
' strFile = Dir()
Counter = Counter + 125
Next
End If
End With
Range("B6:G" & loZeileZielmappe).Copy
Range("B6:G" & loZeileZielmappe).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
Addition = Range("L8")
Range("L7") = Counter
Range("K13") = Counter / 5
Range("L8") = "=SUM(B6:F65536)"
Range("L9") = "=MIN(B6:F65536)"
Range("L10") = "=MAX(B6:F65536)"
Range("L11") = "=L8/L7"
Range("I14") = "=SUM(B6:B65536)"
Range("I15") = "=SUM(C6:C65536)"
Range("I16") = "=SUM(D6:D65536)"
Range("I17") = "=SUM(E6:E65536)"
Range("I18") = "=SUM(F6:F65536)"
Range("L14") = "=I14/K13"
Range("L15") = "=I15/K13"
Range("L16") = "=I16/K13"
Range("L17") = "=I17/K13"
Range("L18") = "=I18/K13"
Range("h4") = Now()
End Sub
Private Function GetFolder(Optional ByVal varDefDir As Variant = "", Optional ByVal strTitle As String = "")
Dim objShell As Object, objFolder As Object
GetFolder = ""
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0&, strTitle, 0&, varDefDir)
If Not objFolder Is Nothing Then GetFolder = objFolder.Self.Path
Range("h3") = Now()
Set objFolder = Nothing
Set objShell = Nothing
End Function
Private Function SplitPath(ByVal strFullName As String, _
ByRef strPath As String, ByRef strName As String) As Boolean
Dim intPos As Integer
intPos = InStrRev(strFullName, "\")
If intPos > 0 Then
strPath = Left(strFullName, intPos)
strName = Mid(strFullName, intPos + 1)
Else
strPath = ""
strName = strFullName
End If
SplitPath = intPos > 0
End Function
... 12-13s wären ja prinzipiell ganz ok... doch die Schwankungen bei Makro#1 sind tw. sehr extrem... manchmal braucht es auch für den gleichen Datensatz 30-35s !
=> nun kommt das eigentlich ärgerliche:
Die Dateien liegen im Netzwerk... die von mir hier angegebenen Zeitmessungen waren sind aber alle mit Dateien, die auch lokal auf dem PC verfügbar waren, durchgeführt worden...
Dadurch, dass die Dateien im Netzwerk liegen, verlangsamt sich der Vorgang nochmals auf ca. 3-4min !
Und hier ist Makro #2 bis zu 1min schneller als Makro #1 !
Ich habe mich hier im Board einige Zeit lang mit Makrobeschleunigung beschäftigt und immer wieder viel das Wort Array !
Doch ich bin ehrlich: Bei Arrays haben schon in der Schule meine Programmierkünste versagt Laughing
Meine Fragen:
1) Warum ist Makro #2 schneller ?
2) Würden hier Arrays den Ablauf beschleunigen ?
3) Wie baue ich hier ein Array ein (Arraytechnisch bin ich keine 0, sondern eine -15) ?
4) Gibt es sonst noch Möglichkeiten, den Ablauf zu beschleunigen ?
Ich bedanke mich bei euch für eure Hilfe und dafür, dass ihr euch mit meinem miserabel gecodeten Makro rumquält ^^
Greets und danke für die Hilfe,
sockly
P.S.
Ich habe mich schonmal an Arrays versucht....
Diese Zeilen kam dabei raus:
Dim varFuellArr(65531, 8) As Variant
varFuellArr(loZaehler , 2) = "='" & strPath & "[" & strFile & "]" & "Tabelle1'!B8"
varFuellArr(ZielDateinameZeile, ZielDatumSpalte) = strFile
varFuellArr(ZielDatumZeile, ZielDatumSpalte) = "='" & strPath & "[" & strFile & "]" & "tabelle1" & "'!A33"
Antwort 2 von nighty
hi all :-)
nur ein kleiner tip
gruss nighty
setze zum anfang eines makros
setze zum ende eines makros
nur ein kleiner tip
gruss nighty
setze zum anfang eines makros
Call EventsOff
setze zum ende eines makros
Call EventsOn
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Antwort 3 von sockly
Hi nighty,
gute Idee, jedoch habe ich die Befehle auch so schon ins Makro eingearbeitet !
Ein eigenes Unterprogramm für diese zu erstellen ist im Hinblick auf die Geschwindigkeit des Makros eher suboptimal !
Greets,
sockly
gute Idee, jedoch habe ich die Befehle auch so schon ins Makro eingearbeitet !
Ein eigenes Unterprogramm für diese zu erstellen ist im Hinblick auf die Geschwindigkeit des Makros eher suboptimal !
Greets,
sockly
Antwort 4 von nighty
hi sockly
ups stimmt ja,wuerde auch blindfisch dazu sagen *grrr*
dann eine andere idee bzw zeitraumaufteilung
gruss nighty
man koennte das openereignis nutzen um schon mal die dateinamen in ein array zu legen,somit waere dein makro etwas kuerzer und auch schneller
DateiNamen(Zaehler1) beinhaltet die dateinamen
dimensionierung geht von 1 bis Zaehler1
hier das makro
ups stimmt ja,wuerde auch blindfisch dazu sagen *grrr*
dann eine andere idee bzw zeitraumaufteilung
gruss nighty
man koennte das openereignis nutzen um schon mal die dateinamen in ein array zu legen,somit waere dein makro etwas kuerzer und auch schneller
DateiNamen(Zaehler1) beinhaltet die dateinamen
dimensionierung geht von 1 bis Zaehler1
hier das makro
Option Explicit
Option Base 1
Sub DateienNamenLesen()
Dim DateiPath As String
Dim DateiEndung As String
Dim DateiName As String
Dim DateiNamen() As String
Dim Zaehler1 As Long
DateiPath = "C:\Excel\"
DateiEndung = "*.xls"
Zaehler1 = 1
ReDim Preserve DateiNamen(Zaehler1)
DateiName = Dir(DateiPath & DateiEndung)
DateiNamen(Zaehler1) = DateiPath & DateiName
DateiName = Dir
Do While DateiName <> ""
Zaehler1 = Zaehler1 + 1
ReDim Preserve DateiNamen(Zaehler1)
DateiNamen(Zaehler1) = DateiPath & DateiName
DateiName = Dir
Loop
End Sub
Antwort 5 von nighty
hi sockly
anstatt ichs gleich mache :-(
das koennte dann so aussehen :-)
gruss nighty
einzufuegen alt+f11/projektexplorer/DeineArbeitsMappe
einzufuegen alt+f11/projektexplorer/AllgemeinesModul
anstatt ichs gleich mache :-(
das koennte dann so aussehen :-)
gruss nighty
einzufuegen alt+f11/projektexplorer/DeineArbeitsMappe
Option Explicit
Option Base 1
Private Sub Workbook_Open()
Dim DateiPath As String
Dim DateiEndung As String
Dim DateiName As String
DateiPath = "C:\Excel\"
DateiEndung = "*.xls"
Zaehler1 = 1
ReDim Preserve DateiNamen(Zaehler1)
DateiName = Dir(DateiPath & DateiEndung)
DateiNamen(Zaehler1) = DateiPath & DateiName
DateiName = Dir
Do While DateiName <> ""
Zaehler1 = Zaehler1 + 1
ReDim Preserve DateiNamen(Zaehler1)
DateiNamen(Zaehler1) = DateiPath & DateiName
DateiName = Dir
Loop
End Sub
einzufuegen alt+f11/projektexplorer/AllgemeinesModul
Global DateiNamen() As String
Global Zaehler1 As Long
Antwort 6 von sockly
Hi nighty und danke für deine Ideen...
ich glaube, durch das einspeichern der Dateinamen in ein Array werde ich nicht so viel Zeit gewinnen... mMn ist der Flaschenhals bei meinem Makro ein anderer, den man aber sicherlich auch mit Arrays lösen kann... Leider bin ich auf diesem Gebiet eine absolute Niete :(
=> das Makro tut ja folgendes:
Es fragt mich erst, wo es nach xls-Dateien suchen soll (dies geschieht ja über die Ordnerabfrage und die GetFolder-Function)...
Dann liest er aus den Dateien immer denselben Bereich ein, und schreibt ihn in die Sammeldatei ! Und ich habe mir gedacht, dass es vllt klüger wäre, die Bereiche erst in ein Array zu schreiben und dann abschließend das Array in die Sammeldatei zu schreiben...
Wobei hier auch gesagt werden muss, dass das Makro die Werte nicht wirklich kopiert, sondern eher auf diese verweist und die Verweise dann durch diesen Befehl auflöst:
da könnte man denk ich mal den größten Zeitgewinn verbuchen...
Meine Frage ist daher jetzt:
Wie bekomme ich diese Zeile so hin, dass der Bereich in ein Makro gebracht wird ?
Hast du oder hat jemand da eine Idee ?
Greets, sockly
ich glaube, durch das einspeichern der Dateinamen in ein Array werde ich nicht so viel Zeit gewinnen... mMn ist der Flaschenhals bei meinem Makro ein anderer, den man aber sicherlich auch mit Arrays lösen kann... Leider bin ich auf diesem Gebiet eine absolute Niete :(
=> das Makro tut ja folgendes:
Es fragt mich erst, wo es nach xls-Dateien suchen soll (dies geschieht ja über die Ordnerabfrage und die GetFolder-Function)...
Dann liest er aus den Dateien immer denselben Bereich ein, und schreibt ihn in die Sammeldatei ! Und ich habe mir gedacht, dass es vllt klüger wäre, die Bereiche erst in ein Array zu schreiben und dann abschließend das Array in die Sammeldatei zu schreiben...
Wobei hier auch gesagt werden muss, dass das Makro die Werte nicht wirklich kopiert, sondern eher auf diese verweist und die Verweise dann durch diesen Befehl auflöst:
Range("A6:G" & loZeileZielmappe).Copy
Range("A6:G" & loZeileZielmappe).PasteSpecial Paste:=xlPasteValues
da könnte man denk ich mal den größten Zeitgewinn verbuchen...
Meine Frage ist daher jetzt:
Wie bekomme ich diese Zeile so hin, dass der Bereich in ein Makro gebracht wird ?
Range(Cells(loZaehler, 2), Cells(loZaehler + 24, 7)).Formula = _
"='" & strPath & "[" & strFile & "]" & "Tabelle1'!B8"
Hast du oder hat jemand da eine Idee ?
Greets, sockly
Antwort 7 von nighty
hi sockly
die bereiche sind recht klein und geschwindigkeitmaessig unerheblich,um deine problemstellung zu beheben bzw zu beschleunigen sind richtige profis bzw informatiker gefragt um entsprechende libarys anzusteuern
diese wiederum verlangen meist eine bezahlung
von daher viel glueck
gruss nighty
die bereiche sind recht klein und geschwindigkeitmaessig unerheblich,um deine problemstellung zu beheben bzw zu beschleunigen sind richtige profis bzw informatiker gefragt um entsprechende libarys anzusteuern
diese wiederum verlangen meist eine bezahlung
von daher viel glueck
gruss nighty
Antwort 8 von nighty
hi sockly
was mir noch einfaellt
gruss nighty
beschaeftige dich mit dictionary objecte
da ich aber amatuer bin und mit excel eigentlicht nicht arbeite(ist fuer mich nur bisl gehirmtraining) fehlt es mir da an routine
gruss nighty
was mir noch einfaellt
gruss nighty
beschaeftige dich mit dictionary objecte
da ich aber amatuer bin und mit excel eigentlicht nicht arbeite(ist fuer mich nur bisl gehirmtraining) fehlt es mir da an routine
gruss nighty
Antwort 9 von sockly
Hi Nighty,
werde ich mal machen !
Ich werde das Kapitel um diese beiden Makros jetzt eh erstmal wieder beenden, da ich noch andere sachen machen muss !
Danke aber für deine zahlreichen Tipps..
MfG,
sockly
werde ich mal machen !
Ich werde das Kapitel um diese beiden Makros jetzt eh erstmal wieder beenden, da ich noch andere sachen machen muss !
Danke aber für deine zahlreichen Tipps..
MfG,
sockly