...




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"

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

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

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

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

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

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

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

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