Excel 2003: Makro für neue Zeilen und Gesamtbetrag errechnen

Moinsen!

Ist es möglich nach einer neuen Kostenart-Nummer
eine neue Zeile einzufügen und dabei den Lohn Gesamtwert ausrechnet und in dieser neuen Zeile ausgibt?

 

wäre super wenn das danach so (siehe Anhang) aussehen würde...

 

Hallo okopalla,

Dein Bild ist verschwommen, ich gehe davon aus, dass in den neuen Zeilen das Total der vorhergehenden Kostenart hin soll.
Falls ein kumulatives Subtotal hin sollte, könnte man das leicht ändern.

Teste dieses Makro... an einer Kopie der Nutzdatei >

Code:

Option Explicit

Sub LohnPerKostenart()
Dim rngSub As Range, shName, i
Dim uppEnd, lowEnd, colArt, colName, colSubT, rowTop, rowEnd, valTop, valSub

shName = "[COLOR="Red"]NameDesBlattes[/COLOR]"   'Name Deines Arbeitsblattes
colArt = [COLOR="red"]2[/COLOR]      'Spalte KostenartNummer B = 2
colName = [COLOR="red"]4[/COLOR]     'Spalte KostenartName D = 4
colSubT = [COLOR="red"]15[/COLOR]    'Spalte SubTotal O = 15
uppEnd = [COLOR="red"]2[/COLOR]      '= oberste ZeilenNummer mit Daten

                'berechnet unterste Zeile mit Daten in Spalte B
lowEnd = Range("B65536").End(xlUp).Row + 1
        
            'zuerst alte SubTotal entfernen... aus vorheriger Bearbeitung
With Sheets(shName)
    .Select
    For i = lowEnd To uppEnd Step -1
        If .Cells(i, colArt).Value = "" Then .Rows(i).EntireRow.Delete
    Next
End With
            'unterste Zeile mit Daten, neu berechnet
lowEnd = Range("B65536").End(xlUp).Row
            'beginnt mit oberster Datenzelle
    Cells(uppEnd, colArt).Select

Do
                'oberste Zeile des gerade bearbeiteten Kostenart-Blocks
    rowTop = ActiveCell.Row
                'KostenartNummer davon
    valTop = ActiveCell.Value
    Do
        ActiveCell.Offset(1, 0).Select
                'wenn gleiche Nummer weiter, sonst >
        If ActiveCell.Value <> valTop Then
                'definiert Grösse dieses Blocks
            rowEnd = ActiveCell.Row
            Set rngSub = Sheets(shName).Range(Cells(rowTop, colSubT), Cells(rowEnd - 1, colSubT))
                'berechnet Subtotal
            valSub = Application.WorksheetFunction.Sum(rngSub)
                'fügt Zeile ein
            ActiveCell.EntireRow.Insert
                'fügt Inhalte ein und formatiert sie
            With Cells(ActiveCell.Row, colName)
                .Value = "Subtotal Kostenart " & valTop
                .Font.Italic = True
            End With
            With Cells(ActiveCell.Row, colSubT)
                .Value = valSub
                .Font.Italic = True
                .Font.Bold = True
            End With
                'geht eine Zeile tiefer und passt Tabellenende an
            ActiveCell.Offset(1, 0).Select
            lowEnd = lowEnd + 1
            Exit Do
        End If
    Loop
Loop Until ActiveCell.Row > lowEnd

End Sub

Die roten Angaben musst Du eventuell Deiner Tabelle anpassen (den Blattnamen sicher).
Der Rest sucht sich seinen Weg dann selbst.

Bedingungen >
- In Spalte B darf untehalb des letzten Datensatzes nichts mehr stehen, sonst findet das Makro das Tabellenende nicht.
- In Spalte B, in den neuen Subtotal-Zeilen, darf nichts stehen, sonst kann das Makro diese Zeilen nicht löschen.

Funktion >

- zuerst müssen die vorhanden Subtotal-Zeilen entfernt werden (von einer vorherigen Ausführung des Makros)
- dann wird die Spalte B von oben nach unten abgearbeitet
- wenn andere Kostenart, wird eine neue Zeile eingefügt und darin
- das Subtotal eingefügt und formatiert (das Format kannst Du im Makro ändern)

Gruss Urs

 

Vielen Dank für deine Bemühungen!
Kommt aber leider ein kleiner Fehler vor:

"Index außerhalb des gültigen Bereichs"

 

...das ist so eine unpräzise Allerweltsfehleranzeige...
Das Makro läuft auf meinem Excel2003 perfekt.

Lass das Makro im VB-Editor einmal im Schrittmodus durchlaufen (immer wieder F8 drücken...).
Und lass gleichzeitig das Lokal-Fenster anzeigen... dort sieht man, wenn in Variablen Unsinn gespeichert werden sollte.
Dann sieht man eventuell in welcher Zeile der Fehler auftritt.

Prinzipiell bedeutet der Index-Fehler, dass das Makro auf etwas zugreifen müsste... das es gar nicht gibt.

Ueberprüfe ob >
- der Name Deines Arbeitsblattes vollkommen identisch ist, mit dem, den Du im Makro ändern musstest
- ob die roten Zahlen im Code nicht auf Unsinniges verweisen

Gruss Urs

 

Yup!Funktioniert alles!
Vielen Dank!

 

eine Frage hätte ich da noch...

rechts neben der Spalte Lohn Gesamtwert ist die Spalte Material Gesamtwert,das müsste auch so ausgerechnet werden wie bei Lohn Gesamtwert...

Sorry,habe recht wenig bis gar keine Kenntnisse in Basic...

 

...ich gehe jetzt davon aus, dass immer eine der beiden Spalten Werte enthält, also wenn nichts in O, dann dafür in P.
Teste das wieder... aber zuerst Blattname etc. anpassen...

Code:

Option Explicit

Sub KostenPerKostenart()
Dim rngSub As Range, shName, i, uppEnd, lowEnd, colArt, colName, _
    colSubLohn, colSubMat, colSub, rowTop, rowEnd, valTop, valSub, valTotLohn, valTotMat

'+++++++++++++  diese Vorgaben immer Deiner Datei anpassen
shName = "NameDesBlattes"   'Name Deines Arbeitsblattes
colArt = 2          'Spalte KostenartNummer B = 2
colName = 4         'Spalte KostenartName D = 4
colSubLohn = 15     'Spalte SubTotalLohn O = 15
colSubMat = 16      'Spalte SubTotalMaterial P = 16
uppEnd = 2          '= oberste ZeilenNummer mit Daten
'+++++++++++++

                'verhindert flackern des Bildschirms
    Application.ScreenUpdating = False
                'berechnet unterste Zeile mit Daten in Spalte B
With Sheets(shName)
    lowEnd = .Range("B65536").End(xlUp).Row + 1
                'zuerst alte SubTotal entfernen... aus vorheriger Bearbeitung
    .Select
    .Rows(lowEnd + 2).EntireRow.Delete
    For i = lowEnd To uppEnd Step -1
        If .Cells(i, colArt).Value = "" Then .Rows(i).EntireRow.Delete
    Next
                'unterste Zeile mit Daten, neu berechnet
    lowEnd = .Range("B65536").End(xlUp).Row
                'Totalsumme auf Null stellen
    valTotLohn = 0
    valTotMat = 0
    
                'beginnt mit oberster Datenzelle
    .Cells(uppEnd, colArt).Select
End With

Do
                'oberste Zeile des gerade bearbeiteten Kostenart-Blocks
    rowTop = ActiveCell.Row
                'KostenartNummer davon
    valTop = ActiveCell.Value
                'wenn dort kein Eintrag > aussteigen
    If valTop = "" Then Exit Sub
                'prüft ob Eintrag in Spalte Lohn
    If Cells(rowTop, colSubLohn) <> "" Then colSub = colSubLohn Else: colSub = colSubMat
        
    Do
        ActiveCell.Offset(1, 0).Select
                'wenn gleiche Nummer weiter, sonst >
        If ActiveCell.Value <> valTop Then
                'definiert Grösse dieses Blocks
            rowEnd = ActiveCell.Row
            Set rngSub = Sheets(shName).Range(Cells(rowTop, colSub), Cells(rowEnd - 1, colSub))
                'berechnet Subtotal + Total
            valSub = Application.WorksheetFunction.Sum(rngSub)
                'addiert Wert zu Totalsummen Lohn oder Material
            If colSub = colSubLohn Then
                valTotLohn = valTotLohn + valSub
            Else
                valTotMat = valTotMat + valSub
            End If
                'fügt Zeile ein
            ActiveCell.EntireRow.Insert
                'fügt Inhalte ein und formatiert sie
            With Cells(ActiveCell.Row, colName)
                .Value = "Subtotal Kostenart " & valTop
                .Font.Italic = True
            End With
            With Cells(ActiveCell.Row, colSub)
                .Value = valSub
                .Font.Italic = True
                .Font.Bold = True
            End With
                'geht eine Zeile tiefer und passt Tabellenende an
            ActiveCell.Offset(1, 0).Select
            lowEnd = lowEnd + 1
            Exit Do
        End If
    Loop
Loop Until ActiveCell.Row > lowEnd

'++++++++++++++++++++  wenn nicht benötigt einfach hier entfernen
                'schreibt GesamtTotal 2 Zeilen unter letztem Subtotal
    With Cells(lowEnd + 2, colName)
        .Value = "Total aller Kostenarten für Lohn bzw. Material"
        .Font.Italic = True
    End With
    With Cells(lowEnd + 2, colSubLohn)
        .Value = valTotLohn
        .Font.Italic = True
        .Font.Bold = True
    End With
    With Cells(lowEnd + 2, colSubMat)
        .Value = valTotMat
        .Font.Italic = True
        .Font.Bold = True
    End With
'+++++++++++++++++++

                'schaltet Bildschirmerneuerung wieder ein
    Application.ScreenUpdating = True

End Sub

Zusätzlich zur neuen Kolonne P habe ich noch geändert >

- ScreenUpdating verhindert Bildschirm-Flackern während der Ausführung des Makros
- falls das Makro ausgeführt wird, wenn noch nichts ausgefüllt wurde, kommt der Debugger und schimpft... das erschreckt sensible Leute >> jetzt tut das Makro dann einfach gar nichts (... wenn in der obersten DatenZeile keine KostenArtNummer ist).
- da das Makro die Subtotals schon kennt, lasse ich es am Ende das GesamtTotal gleich hinschreiben...

Denk dran > wenn Du in der Tabelle Spalten verschiebst, musst Du das Makro entsprechend anpassen.

Kenntnisse in VBA >> hatte ich mir fast gedacht, sonst wärst Du wohl nicht hierher gekommen...
Ich habe deshalb alles absichtlich auseinander gezogen und gut dokumentiert... vielleicht hilft es ja für die Zukunft...

Gruss Urs

 

Danke nochmal!

Das wars denn...erstmal