Hallo Christian123,
die meiste Zeit geht wohl beim Umsortieren der Zellen drauf. Ich schlage daher einen anderen Ansatz vor. Ob dieser wirklich schneller ist, habe ich nicht geprüft, da ich nicht erst so umfangreiche Dateien erzeugen möchte. Ich vergleiche mit 'If Left(Cells(z, 1), 13) = Left(tb(1, i), 13) Then' nur jeweils volle Stunden. Wenn aber nur volle Stunden vorhanden sind, kannst du Left() jeweils weglassen, weil auch hier Zeit verloren geht, wenn das tausende Male gemacht werden soll.
Sub Listenkorrektur()
Application.ScreenUpdating = False
For s = 1 To Sheets.Count - 4
Sh = "Anlage_" & s
For Each WS In Worksheets
If WS.Name = Sh Then
Sheets(Sh).Activate
e = Cells(65536, 1).End(xlUp).Row
c = (Cells(e, 1) - Cells(2, 1)) * 24 + 2
ReDim tb(8, c)
t = Cells(2, 1)
For i = 2 To c
tb(1, i) = Format(t + (i - 2) / 24, "dd.mm.yyyy hh:mm")
Next i
z = 2
For i = 2 To c
If Left(Cells(z, 1), 13) = Left(tb(1, i), 13) Then
For j = 2 To 7
tb(j, i) = Cells(z, j)
Next j
z = z + 1
End If
Next i
Cells.Delete
For i = 2 To c
For j = 1 To 8
Cells(i, j) = tb(j, i)
Next j
Next i
Exit For
End If
Next
Next s
Application.ScreenUpdating = True
End Sub
Ein Feedback wäre nicht schlecht, um zu erfahren, ob sich eine Zeitverkürzung eingestellt hat.
Gruß
Holger
Christian123 schrieb am 21.01.2010 17:22:39:
Hallo VBA-Spezialisten,
schon einmal vielen Dank im Voraus für die Hilfe. Und hier mein Problem:
Ich habe eine Schleife in VBA geschrieben, doch diese dauert mir zu lange. Nun wollte ich diese in ein array einlesen und mit bestimmten Bedingungen wieder ausgeben lassen. (Weiß jedoch nicht wie)
Die Matrix ist so, das in der 1. Spalte Datums/Zeit-Angaben stehen und in Spalte 2-8 Zuordnungen. Nun ist es jedoch so, das bestimmte Datumswerte fehlen. Diese wollte ich in der ersten Spalte auffüllen (Ohne für diese später Zuordnungen aufzufüllen -> Spalte 2-8 bleibt bei den neu hinzugefügten Datumswerten leer)
Am ende soll in Spalte 1 eine fortlaufendes datum im Stundenrythmus stehen. (ertser und letzter Wert in der Ursprungsliste sind fix und somit die Start- und Stop-Werte)
Mein bisheriges Makro:
Sub Listenkorrektur()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo Ende
For s = 1 To Sheets.Count - 4
e = Sheets("Anlage_" & s).Cells(65536, 1).End(xlUp).Row
For a = e To 3 Step -1
If Sheets("Anlage_" & s).Cells(a - 1, 1) = "" Then
Rows(a - 1 & ":" & a - 1).Delete
a = a + 1
End If
If Format(Sheets("Anlage_" & s).Cells(a, 1) + 1 / 24, "dd.mm.yyyy hh:mm") <> _
Format(Sheets("Anlage_" & s).Cells(a - 1, 1) * 1, "dd.mm.yyyy hh:mm") Then
Sheets("Anlage_" & s).Rows(a & ":" & a).Insert Shift:=xlDown
Sheets("Anlage_" & s).Cells(a, 1) = Sheets("Anlage_" & s).Cells(a + 1, 1) + 1 / 24
a = a + 1
End If
Next
Next
Exit Sub
Ende:
Application.Calculation = xlCalculationAutomatic
End Sub
Wie ließe sich da Makro beschleunigen, da mehrere Tausend Zeilen durchlaufen werden!
Tschüß, schnelle Hilfe wäre echt toll! |