Monatswerte zusammenfassen | Herbers Excel-Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Bsp() Dim oDic As Object, ArrayDaten() Dim n& Set oDic = CreateObject("Scripting.Dictionary") With Tabelle1 'Tabelle anpassen ArrayDaten = .Range("B2", Cells(Rows.Count, 2).End(xlUp)).Resize(, 2) oDic("Datum") = "Summe" 'Überschrift For n = 1 To Ubound(ArrayDaten) oDic(ArrayDaten(n, 1)) = oDic(ArrayDaten(n, 1)) + ArrayDaten(n, 2) Next n With .Range("E1").Resize(oDic.Count, 2) 'Ausgabe anpassen .EntireColumn.Clear .Columns(1).Value = ArrayTranspose(oDic.keys) .Columns(2).Value = ArrayTranspose(oDic.items) .Rows(1).Font.Bold = True .EntireColumn.AutoFit End With End With End Sub Function ArrayTranspose(varArray) Dim n&, nn&, NewArray() Redim NewArray(1 To Ubound(varArray) - Lbound(varArray) + 1, 1 To 1) For n = Lbound(varArray) To Ubound(varArray) nn = nn + 1 NewArray(nn, 1) = varArray(n) Next n ArrayTranspose = NewArray End Function

Hallo,
könnte man so machen, ohne Fehlerprüfung ob Daten vorhanden.

Option Explicit

Sub Bsp()
Dim oDic As Object, ArrayArtikel(), ArrayDaten()
Dim ArrayAusgabe(), varKeys
Dim n&, nn&, nC&

Set oDic = CreateObject("Scripting.Dictionary")

'Überschrift 
Redim Preserve ArrayAusgabe(1 To 3, 1 To 1)
nC = 1
ArrayAusgabe(1, nC) = "Artikel"
ArrayAusgabe(2, nC) = "Datum"
ArrayAusgabe(3, nC) = "Summe"
            
With Tabelle1 'Tabelle anpassen 
    ArrayDaten = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
    
    For n = 1 To Ubound(ArrayDaten)
        oDic(ArrayDaten(n, 1)) = 0
    Next n
    
    ArrayArtikel = oDic.keys
    ArrayDaten = .Range("A2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3)
        
        For nn = Lbound(ArrayArtikel) To Ubound(ArrayArtikel)
            oDic.RemoveAll
            For n = 1 To Ubound(ArrayDaten)
                If ArrayArtikel(nn) = ArrayDaten(n, 1) Then
                    oDic(ArrayDaten(n, 2)) = oDic(ArrayDaten(n, 2)) + ArrayDaten(n, 3)
                End If
            Next n
            
            Redim Preserve ArrayAusgabe(1 To 3, 1 To Ubound(ArrayAusgabe, 2) + oDic.Count)
            
            For Each varKeys In oDic.keys
                nC = nC + 1
                ArrayAusgabe(1, nC) = ArrayArtikel(nn)
                ArrayAusgabe(2, nC) = varKeys
                ArrayAusgabe(3, nC) = oDic(varKeys)
            Next varKeys

        Next nn
        
        ArrayAusgabe = ArrayTranspose(ArrayAusgabe)
        
        With .Range("E1").Resize(Ubound(ArrayAusgabe), 3) 'Ausgabe Überschrift 
            .EntireColumn.Clear
            .Value = ArrayAusgabe
            .Rows(1).Font.Bold = True
            .EntireColumn.AutoFit
        End With

End With 'Tabelle1 
End Sub

Function ArrayTranspose(varArray)
Dim n&, nn&, NewArray()
Redim NewArray(1 To Ubound(varArray, 2), 1 To Ubound(varArray))
For n = Lbound(varArray) To Ubound(varArray)
    For nn = Lbound(varArray, 2) To Ubound(varArray, 2)
        NewArray(nn, n) = varArray(n, nn)
    Next nn
Next n
ArrayTranspose = NewArray
End Function

Gruß Tino

Sub Bsp() Dim oDic(2) As Object, ArrayDaten() Dim n&, strTemp$ Set oDic(0) = CreateObject("Scripting.Dictionary") Set oDic(1) = CreateObject("Scripting.Dictionary") Set oDic(2) = CreateObject("Scripting.Dictionary") 'Überschrift oDic(0)("Artikel") = "Artikel" oDic(1)("Datum") = "Datum" oDic(2)("Summe") = "Summe" With Tabelle1 'Tabelle anpassen ArrayDaten = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 3) For n = 1 To Ubound(ArrayDaten) strTemp = ArrayDaten(n, 1) & ArrayDaten(n, 2) oDic(0)(strTemp) = ArrayDaten(n, 1) oDic(1)(strTemp) = ArrayDaten(n, 2) oDic(2)(strTemp) = oDic(2)(strTemp) + ArrayDaten(n, 3) Next n With Application .ScreenUpdating = False .EnableEvents = False With .Range("E1").Resize(oDic(0).Count, 3) 'Ausgabe Überschrift .EntireColumn.Clear .Columns(1) = ArrayTranspose(oDic(0).items) .Columns(2) = ArrayTranspose(oDic(1).items) .Columns(3) = ArrayTranspose(oDic(2).items) .Rows(1).Font.Bold = True .EntireColumn.AutoFit End With .ScreenUpdating = True .EnableEvents = True End With 'Application End With 'Tabelle1 End Sub Function ArrayTranspose(varArray) Dim n&, nn&, NewArray() Redim NewArray(1 To Ubound(varArray) - Lbound(varArray) + 1, 1 To 1) For n = Lbound(varArray) To Ubound(varArray) nn = nn + 1 NewArray(nn, 1) = varArray(n) Next n ArrayTranspose = NewArray End Function

Beliebteste Forumthreads (12 Monate)

Monatswerte zusammenfassen | Herbers Excel-Forum

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread