Microsoft Excel

Herbers Excel/VBA-Archiv

Makroausführung

    Betrifft: Makroausführung von: Jürgen
    Geschrieben am: 31.08.2003 09:41:20

    Ich bins schon wieder.
    Hab jetzt endlich alles dank eurer Hilfe soweit fertig. Nur ein Problem existiert noch:
    Die Berechnungen des Makros funktionieren nur wenn ich mich auf dem entsprechenden Blatt (in dem Fall Kalkulation) befinde. Befinde ich mich auf einem anderen Blatt, so wird im Blatt Kalkulation gar nichts getan. Ist wahrscheinlich ein banaler fehler von mir.
    Hier der Code:

    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)
        
        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
    

      


    Betrifft: AW: Makroausführung von: Hajo_Zi
    Geschrieben am: 31.08.2003 09:48:42

    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
    


    Grußformel

    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.


      


    Betrifft: AW: Makroausführung von: Jürgen
    Geschrieben am: 31.08.2003 10:36:49

    Danke!!!!!!!!!!!
    Jetzt geht es.
    Man lernt halt nie aus.
    Gruß,
    Jürgen


      


    Betrifft: Danke für die Rückmeldung oT von: Hajo_Zi
    Geschrieben am: 31.08.2003 11:25:43