Makro langsam - tunen möglich? | HERBERS Excel Forum

Sub Ermittlung(row, d) iv = 1 Do While row - iv > 0 If Cells(row - iv, 12) = d Then Cells(row - iv, 12).Activate: Cells(1, 15).Value = Cells( _ ActiveCell.row, ActiveCell.Column - 8): Cells(1, 8).Value = Cells(1, 15) If Cells(row - iv, 12) = d Then iv = row iv = iv + 1 Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub TLB_New() Sheets("Statistik").Select Reverse = 5 JC_SL = 500 JC_SH = 500 row = 2 col = 8 x = 1 y = 1 Dim Zeile As Long Zeile = ActiveSheet.UsedRange.Rows.Count '----------------------------------------------------------------------------------------------- _ Cells(1, 8).Value = JC_SL Cells(1, 9).Value = JC_SL Cells(1, 12).Value = JC_SH Cells(1, 13).Value = JC_SH '----------------------------------------------------------------------------------------------- _ For i = 1 To Zeile - 2 If Cells(row, 4) Reverse Then c = Cells(row, 8) - Reverse: Call _ Ermittlung1_new(row, c) If Cells(row, 4) Cells(1, 12) Then Cells(row, 12) = y Else Cells(row, 12) = 0 If Cells(row, 4) > Cells(1, 12) Then Cells(row, 12).Interior.ColorIndex = 36 If Cells(row, 12) = 1 Then Cells(1, 14) = Cells(row, 4) If Cells(row, 4) > Cells(1, 12) Then y = y + 1 If Cells(row, 12) > Reverse Then d = Cells(row, 12) - Reverse: Call _ Ermittlung2_new(row, d) If Cells(row, 4) > Cells(1, 12) Then Cells(1, 12).Value = Cells(row, 4) If Cells(row, 12) = 1 Then x = 1 If Cells(row, 8) = 1 Then y = 1 row = row + 1 Next i End Sub

Sub Ermittlung1_new(row, c) iii = 1 Do While row - iii > 0 If Cells(row - iii, 8) = c Then Cells(row - iii, 8).Activate: Cells(1, 11).Value = Cells( _ ActiveCell.row, ActiveCell.Column - 4): Cells(1, 12).Value = Cells(1, 11) If Cells(row - iii, 8) = c Then iii = row iii = iii + 1 Loop End Sub

Sub Ermittlung2_new(row, d) iv = 1 Do While row - iv > 0 If Cells(row - iv, 12) = d Then Cells(row - iv, 12).Activate: Cells(1, 15).Value = Cells( _ ActiveCell.row, ActiveCell.Column - 8): Cells(1, 8).Value = Cells(1, 15) If Cells(row - iv, 12) = d Then iv = row iv = iv + 1 Loop End Sub

Sub Ermittlung(row, d) Dim Zeile As Long iv = 1 With Sheets("Statistik") Do While row - iv > 0 If .Cells(row - iv, 12) = d Then .Cells(1, 15).Value = .Cells(row - iv, 4) .Cells(1, 8).Value = .Cells(1, 15) End If If .Cells(row - iv, 12) = d Then iv = row End If iv = iv + 1 Loop Zeile = .UsedRange.Rows.Count End With End Sub

Sub Ermittlung(row, d) 'Dim-Zeilen muss man nicht am Anfang schreiben, 'aber sollten immer zuerst im Code stehen Dim Zeile As Long iv = 1 'ohne das Blatt mit Activate zu wechseln, 'wird mit With... trotzdem das gewünschte 'Blatt angesprochen With Sheets("Statistik") Do While row - iv > 0 'jeder Zugriff auf eine Zelle im Blatt, 'welches mit With... eingeleitet wurde, 'muss mit einem vorangestellten Punkt (.) 'beginnen If .Cells(row - iv, 12) = d Then .Cells(1, 15).Value = .Cells(row - iv, 4) .Cells(1, 8).Value = .Cells(1, 15) End If If .Cells(row - iv, 12) = d Then iv = row End If iv = iv + 1 Loop Zeile = .UsedRange.Rows.Count End With End Sub

Hallo Thorsten,
ich baue das mal ein, habe aber das Problem mit dem Tabellenblatt:
Ich muß am Anfang der Prozedur das Tabellenblatt ansprechen...
Hier mal das Gesamtkonstrukt:

Sub TLB_New()
Sheets("Statistik").Select
Reverse = 5
JC_SL = 500
JC_SH = 500
row = 2
col = 8
x = 1
y = 1
Dim Zeile As Long
Zeile = ActiveSheet.UsedRange.Rows.Count
'----------------------------------------------------------------------------------------------- _
Cells(1, 8).Value = JC_SL
Cells(1, 9).Value = JC_SL
Cells(1, 12).Value = JC_SH
Cells(1, 13).Value = JC_SH
'----------------------------------------------------------------------------------------------- _
For i = 1 To Zeile - 2
If Cells(row, 4)  Reverse Then c = Cells(row, 8) - Reverse: Call  _
Ermittlung1_new(row, c)
If Cells(row, 4)  Cells(1, 12) Then Cells(row, 12) = y Else Cells(row, 12) = 0
If Cells(row, 4) > Cells(1, 12) Then Cells(row, 12).Interior.ColorIndex = 36
If Cells(row, 12) = 1 Then Cells(1, 14) = Cells(row, 4)
If Cells(row, 4) > Cells(1, 12) Then y = y + 1
If Cells(row, 12) > Reverse Then d = Cells(row, 12) - Reverse: Call  _
Ermittlung2_new(row, d)
If Cells(row, 4) > Cells(1, 12) Then Cells(1, 12).Value = Cells(row, 4)
If Cells(row, 12) = 1 Then x = 1
If Cells(row, 8) = 1 Then y = 1
row = row + 1
Next i
End Sub

Sub Ermittlung1_new(row, c)
iii = 1
Do While row - iii > 0
If Cells(row - iii, 8) = c Then Cells(row - iii, 8).Activate: Cells(1, 11).Value = Cells( _
ActiveCell.row, ActiveCell.Column - 4): Cells(1, 12).Value = Cells(1, 11)
If Cells(row - iii, 8) = c Then iii = row
iii = iii + 1
Loop
End Sub

Sub Ermittlung2_new(row, d)
iv = 1
Do While row - iv > 0
If Cells(row - iv, 12) = d Then Cells(row - iv, 12).Activate: Cells(1, 15).Value = Cells( _
ActiveCell.row, ActiveCell.Column - 8): Cells(1, 8).Value = Cells(1, 15)
If Cells(row - iv, 12) = d Then iv = row
iv = iv + 1
Loop
End Sub

Ich hoffe, das hilft.
Ich denke, wenn man die Selects rausbekommen würde. bringt das schon was.
Wie ist es denn eigentlich mit
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
und am Ende alles wieder zurück? Bringt das was bzw. geht das?
Gruß Jens

Sub Ermittlung2(row, c) iii = 1 Do While row - iii > 0 If Cells(row - iii, 8) = c Then Cells(row - iii, 8).Activate: Cells(1, 11).Value = Cells( _ ActiveCell.row, ActiveCell.Column - 4): Cells(1, 12).Value = Cells(1, 11) If Cells(row - iii, 8) = c Then iii = row iii = iii + 1 Loop End Sub

Sub Ermittlung1(row, d) iv = 1 Do While row - iv > 0 If Cells(row - iv, 12) = d Then Cells(1, 15).Value = Cells(row - iv, 4) Cells(1, 8).Value = Cells(1, 15) End If If Cells(row - iv, 12) = d Then iv = row End If iv = iv + 1 Loop End Sub

Hallo Jens,
prinzipiell können Makros über zwei Möglichkeiten wesentlich schneller arbeiten:
1. Mit "Application.Screenupdating = False" muss der Bildschirminhalt nicht immer aktualisiert werden. Bitte am Ende des Makros wieder auf "True" setzen.
2. Bei jeder Änderung des Zellinhalts werden alle Zellen neu berechnet. Die Makros werden um ein Vielfaches beschleunigt, wenn diese automatische Berechnung vorübergehend mit "Application.Calculation = xlCalculationManual" deaktiviert wird. Falls aber im Makro eine Neuberechnung der Zellen notwendig ist, setze zuvor "Application.Calculate" ein. Am Ende des Makros solltest du die automatische Berechnung mit "Application.Calculation = xlCalculationAutomatic" wieder aktivieren.
Viele Grüße
Martin

Beliebteste Forumthreads (12 Monate)

Makro langsam - tunen möglich?

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread