Makroausführung

Sub WerteRuecksetzen() Dim i As Long Dim z As Long Dim LetzteZeile As Long With Worksheets("Kalkulation") For z = 8 To .Range("B65536").End(xlUp).Row If .Cells(z, 2) = "" Then LetzteZeile = z Exit For End If Next z For i = 8 To .Range("FH" & LetzteZeile).End(xlUp).Row If .Cells(i, 164) > "0" Then Range("FE" & i).Value = "0" Range("FP" & i).Value = "0" Range("FN" & i).Value = "0" Application.CutCopyMode = False End If Next i End With End Sub

Sub AbgleichVermoegen() Dim i As Long Nochmal: With Worksheets("Kalkulation") For i = 8 To .Range("FC65536").End(xlUp).Row If .Cells(i, 159) = "0" Then If Range("FJ" & i).Value < Range("FK" & i).Value Then Range("FC" & i).Copy Range("FC" & i - 1).PasteSpecial Paste:=xlPasteValues GoTo Nochmal Else Range("FJ" & i).Copy Range("FC" & i).PasteSpecial Paste:=xlPasteValues End If Application.CutCopyMode = False Exit For End If Next i End With End Sub

Sub ZeilenFinden() Dim i As Long Dim z As Long Dim LetzteZeile As Long With Worksheets("Kalkulation") For z = 8 To .Range("B65536").End(xlUp).Row If .Cells(z, 2) = "" Then LetzteZeile = z Exit For End If Next z For i = 8 To .Range("FI" & LetzteZeile).End(xlUp).Row If .Cells(i, 165) > "0" Then WerteBerechnen (i) If i = LetzteZeile Then Exit For End If Next i End With End Sub

Sub WerteBerechnen(Zeile As Long) If Range("FI" & Zeile).Value < Range("FM" & Zeile).Value Then Range("FI" & Zeile).Copy Range("FN" & Zeile).PasteSpecial Paste:=xlPasteValues Else Range("FM" & Zeile).Copy Range("FN" & Zeile).PasteSpecial Paste:=xlPasteValues End If If Range("FI" & Zeile).Value < Range("FK" & Zeile).Value Then Range("FI" & Zeile).Copy Range("FP" & Zeile).PasteSpecial Paste:=xlPasteValues Else Range("FK" & Zeile).Copy Range("FP" & Zeile).PasteSpecial Paste:=xlPasteValues End If If Range("FI" & Zeile).Value > "0" Then Range("FI" & Zeile).Copy Range("FE" & Zeile).PasteSpecial Paste:=xlPasteValues End If Application.CutCopyMode = False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jürgen

ich habe mir Deinen Code jetzt nur zu dem angesprochenen Problem angesehen. Es fehlten die Punkte vor Range und beim Letzten auch das With.

Option Explicit


Sub Kalkulation_Berechnen()
WerteRuecksetzen
AbgleichVermoegen
ZeilenFinden
End Sub


Sub WerteRuecksetzen()
Dim i As Long
Dim z As Long
Dim LetzteZeile As Long
With Worksheets("Kalkulation")
For z = 8 To .Range("B65536").End(xlUp).Row
If .Cells(z, 2) = "" Then
LetzteZeile = z
Exit For
End If
Next z
For i = 8 To .Range("FH" & LetzteZeile).End(xlUp).Row
If .Cells(i, 164) > "0" Then
.Range("FE" & i).Value = "0"
.Range("FP" & i).Value = "0"
.Range("FN" & i).Value = "0"
Application.CutCopyMode = False
End If
Next i
End With
End Sub


Sub AbgleichVermoegen()
Dim i As Long
Nochmal:
With Worksheets("Kalkulation")
For i = 8 To .Range("FC65536").End(xlUp).Row
If .Cells(i, 159) = "0" Then
If .Range("FJ" & i).Value < .Range("FK" & i).Value Then
.Range("FC" & i).Copy
.Range("FC" & i - 1).PasteSpecial Paste:=xlPasteValues
GoTo Nochmal
Else
.Range("FJ" & i).Copy
.Range("FC" & i).PasteSpecial Paste:=xlPasteValues
End If
Application.CutCopyMode = False
Exit For
End If
Next i
End With
End Sub


Sub ZeilenFinden()
Dim i As Long
Dim z As Long
Dim LetzteZeile As Long
With Worksheets("Kalkulation")
For z = 8 To .Range("B65536").End(xlUp).Row
If .Cells(z, 2) = "" Then
LetzteZeile = z
Exit For
End If
Next z
For i = 8 To .Range("FI" & LetzteZeile).End(xlUp).Row
If .Cells(i, 165) > "0" Then WerteBerechnen (i)
If i = LetzteZeile Then
Exit For
End If
Next i
End With
End Sub


Sub WerteBerechnen(Zeile As Long)
With Worksheets("Kalkulation")
If .Range("FI" & Zeile).Value < .Range("FM" & Zeile).Value Then
.Range("FI" & Zeile).Copy
.Range("FN" & Zeile).PasteSpecial Paste:=xlPasteValues
Else
.Range("FM" & Zeile).Copy
.Range("FN" & Zeile).PasteSpecial Paste:=xlPasteValues
End If
If .Range("FI" & Zeile).Value < .Range("FK" & Zeile).Value Then
.Range("FI" & Zeile).Copy
.Range("FP" & Zeile).PasteSpecial Paste:=xlPasteValues
Else
.Range("FK" & Zeile).Copy
.Range("FP" & Zeile).PasteSpecial Paste:=xlPasteValues
End If
If .Range("FI" & Zeile).Value > "0" Then
.Range("FI" & Zeile).Copy
.Range("FE" & Zeile).PasteSpecial Paste:=xlPasteValues
End If
Application.CutCopyMode = False
End With
End Sub

Falls Code vorhanden wurde dieser getestet unter Betriebssystem XP Pro und Excel Version XP SBE.
Bitte kein Mail, Probleme sollen im Forum gelöst werden.

Microsoft MVP für Excel

Das Forum lebt auch von den Rückmeldungen.

Zurzeit gibt es wieder Probleme mit der E-Mail Benachrichtigung.

Ich bekomme Mails zu Beiträgen an denen ich nicht beteiligt bin und zusätzlich noch Mails zu meinen eigenen Beiträgen.
Das Problem mit den eigenen Benachrichtigung kann gelöst werden durch Lösche und Neuanmelden. Dieses möchte ich aber nicht jeden Tag machen.
Um dieses Problem erstmal zu beseitigen habe ich die automatische Mailbenachrichtigung abgeschaltet.
Aus diesem Grunde ist es dem Zufall überlassen ob auf Rückfragen Antworten von mir kommen.

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread