Supportnet Computer
Planet of Tech

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:
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
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

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

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

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:

   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

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

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

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: