OpenOffice.info

Code: Alles auswählen

Sub GutschriftenZusammenfassen()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim name As String
    Dim gutschrift As Double

    Set ws = ThisWorkbook.Sheets("Sheet1") ' Passe den Sheet-Namen an
    Set dict = CreateObject("Scripting.Dictionary")

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Bestimmt die letzte Zeile der Tabelle

    ' Gehe die Zeilen durch und füge die Gutschriften pro Mitarbeiter zusammen
    For i = 2 To lastRow ' assuming the first row is headers
        name = ws.Cells(i, 1).Value ' Name in Spalte A
        gutschrift = ws.Cells(i, 8).Value ' Gutschrift in Spalte H

        ' Falls der Name noch nicht im Dictionary ist, füge ihn hinzu
        If Not dict.exists(name) Then
            dict.Add name, gutschrift
        Else
            dict(name) = dict(name) + gutschrift ' Falls der Name bereits im Dictionary ist, summiere die Gutschrift
        End If
    Next i

    ' Lösche die alten Daten (außer der ersten Zeile)
    ws.Range("A2:H" & lastRow).ClearContents

    ' Schreibe die gesammelten Daten zurück in die Tabelle
    i = 2
    For Each key In dict.keys
        ws.Cells(i, 1).Value = key ' Name
        ws.Cells(i, 8).Value = dict(key) ' Gutschrift
        i = i + 1
    Next key

    MsgBox "Die Gutschriften wurden erfolgreich zusammengefasst!", vbInformation

End Sub

Code: Alles auswählen

=WENN(ZÄHLENWENN(A12:A$30;A13)>1;"";SUMMENPRODUKT($A$13:$A$30=A13;$H$13:$H$30))