Optimierungsbedarf Makrocode wg. Laufzeitproblemen

Servus zusammen,
ich brauche mal Hilfe von euch Profis um einen Makrocode zu optimieren.
Vor einiger Zeit habe ich mal einen Code zusammengebastelt, der mir eine Tabelle vom ersten bis zum letzten Eintrag durchgeht und Mitarbeiterspezifisch jeden Eintrag in eine eigene Excel-Datei kopiert, bzw. eine neue Datei anlegt.
Das funktionierte in der Vergangenheit schon, wenngleich mein Code gefühlte Ewigkeiten bei der Ausführung benötigt (immer wieder workbook.open und workbook.close). Bei maximal 20 Zeilen war es aber bisher zu verschmerzen.
Jetzt wollte ich mit diesem Makro das gleiche bei einer Quelldatei mit mehr als 1000 Einträgen machen aber
best case: es dauert gefühlte Stunden, oder
worst case: Excel schmiert wegen RAM-Problemen ab
Da gibt es sicher eine bessere Lösung...
Anbei mal eine Beispieldatei.
https://www.herber.de/bbs/user/118034.xlsm
Ich bedanke mich im Voraus für jede eure Ideen und Vorschläge.
Grüße, Bernd

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Aufteilung() Dim rng As Range Dim sPath$, sFullPath$ Dim oApp As Excel.Application, oWB As Workbook, NewWBPath$ Dim nCountNeu&, nCountVorhanden& sPath = ThisWorkbook.Path sPath = sPath & IIf(Right$(sPath, 1) <> "\", "\", "") 'Datenbereich ohne Zeile 1 With Tabelle3 Set rng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)) If rng.Rows(1).Row < 2 Then Exit Sub End With 'In Ordner einloggen ChDrive sPath ChDir sPath 'Schleife über alle Zeilen im Bereich For Each rng In rng.Rows If rng.Cells(1, 4).Value <> "" Then 'nicht leer sFullPath = sPath & rng.Cells(1, 4).Value & ".xlsx" 'Pfad + neu WB Name If Dir(sFullPath, vbNormal) = "" Then 'Datei nicht vorhanden If NewWBPath = "" Then 'erste Datei als Pfad? If oWB Is Nothing Then 'neue Application erstellen Set oApp = New Excel.Application Set oWB = oApp.Workbooks.Add End If 'speichern als xlsx oWB.SaveAs Filename:=sFullPath, FileFormat:=51 NewWBPath = sFullPath 'Pfad speichern 'alles schließen oWB.Close False oApp.Quit Set oWB = Nothing Set oApp = Nothing nCountNeu = nCountNeu + 1 Else 'nur kopieren FileCopy NewWBPath, sFullPath nCountNeu = nCountNeu + 1 End If Else nCountVorhanden = nCountVorhanden + 1 End If End If Next On Error Resume Next 'Evlt. aufräumen If Not oWB Is Nothing Then oWB.Close False: Set oWB = Nothing If Not oApp Is Nothing Then oApp.Quit: Set oApp = Nothing MsgBox "Es wurden " & nCountNeu & " Dateien neu erstellt" & vbCr & _ "Es waren " & nCountVorhanden & " Dateien bereits vorhanden!", vbInformation End Sub

Servus Tino,
danke für deine Bemühungen. Ich schreibe aber die jeweiligen Einträge in die neuen Dateien.
Auszug aus meinem alten Codestück:


For i = 2 To intLZ_Q
strDatei = strPfad & wbQ.Sheets(1).Cells(i, 4) & ".xlsx"
If DateiExistiert(strDatei) Then
Set wbZ = Workbooks.Open(strDatei)
intLZ_Z = wbZ.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
        wbQ.Sheets(1).Rows(i).Copy Destination:=wbZ.Sheets(1).Cells(intLZ_Z, 1)
        wbZ.Close True
Else
Set wbZ = Workbooks.Add
        With wbZ.Sheets(1)
wbQ.Sheets(1).Rows(1).Copy Destination:=.Range("A1")
intLZ_Z = .Cells(Rows.Count, 1).End(xlUp).Row + 1
wbQ.Sheets(1).Rows(i).Copy Destination:=.Cells(intLZ_Z, 1)
End With
        wbZ.SaveAs Filename:=strDatei, FileFormat:=51
wbZ.Close False
End If
Next i

Wo müsste ich das in deinem Code einfügen?
Ich spekuliere mal, falls ich deinen Code richtig lese:


For Each rng In rng.Rows
If rng.Cells(1, 4).Value  "" Then 'nicht leer
sFullPath = sPath & rng.Cells(1, 4).Value & ".xlsx" 'Pfad + neu WB Name
If Dir(sFullPath, vbNormal) = "" Then 'Datei nicht vorhanden
If NewWBPath = "" Then 'erste Datei als Pfad?
If oWB Is Nothing Then 'neue Application erstellen
Set oApp = New Excel.Application
Set oWB = oApp.Workbooks.Add
End If
==> genau hier rein 
'speichern als xlsx
oWB.SaveAs Filename:=sFullPath, FileFormat:=51
NewWBPath = sFullPath 'Pfad speichern
'alles schließen
oWB.Close False
oApp.Quit
Set oWB = Nothing
Set oApp = Nothing
nCountNeu = nCountNeu + 1
==> Den Code in beiden nachfolgendem "Else" versteh ich nicht?!
Else
'nur kopieren
FileCopy NewWBPath, sFullPath
nCountNeu = nCountNeu + 1
End If
Else
nCountVorhanden = nCountVorhanden + 1
End If
End If
Next

Könntest du mich bitte noch aufklären?
Vielen Dank und Grüße, Bernd

Beliebteste Forumthreads (12 Monate)

Optimierungsbedarf Makrocode wg. Laufzeitproblemen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread