Code für die personl.xls
WalterK
der folgende Code von Tino funktioniert wenn ich ihn in der Tabelle starte, wenn ich ihn in der personl.xls speichere und von dort starte wird als Fehler die Zeile
NewWS.Cells(3, n).Resize(myDic(n).Count) = .Transpose(myDic(n).items)
markiert.
Mit diesem Code summiere ich die Spalten 4 bis 17 wenn der ID (das sind die Spalten 1 bis 3) identisch ist.
Option Explicit
Sub Zusammenfassen()
Dim ArrayData(), myDic(1 To 50)
Dim n&, nn&, nnn&
Dim strID$
Dim NewWS As Worksheet
Set NewWS = ThisWorkbook.ActiveSheet
With NewWS 'Vorher evtl. Tabelle anpassen
ArrayData = .Range("A3", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 50)
End With
For n = 1 To 50
Set myDic(n) = CreateObject("Scripting.Dictionary")
Next n
For n = 1 To UBound(ArrayData)
If ArrayData(n, 4) 0 Then 'überspringen wenn Summe 0
strID = ArrayData(n, 1) & ArrayData(n, 2) & ArrayData(n, 3)
If Not myDic(1).exists(strID) Then '1. ID
For nnn = 18 To 50
myDic(nnn)(strID) = ArrayData(n, nnn)
Next nnn
End If
For nnn = 1 To 3 'Name; Nr; Art
myDic(nnn)(strID) = ArrayData(n, nnn)
Next nnn
' myDic(4)(strID) = "=SUM(RC5:RC17)" 'Summe
For nnn = 4 To 17 'Monate Jan bis Dez
myDic(nnn)(strID) = myDic(nnn)(strID) + ArrayData(n, nnn)
If myDic(nnn)(strID) = 0 Then myDic(nnn)(strID) = Empty
Next nnn
End If
Next n
Erase ArrayData
With Application
.ScreenUpdating = False
.EnableEvents = False
With NewWS
.EnableCalculation = False
.Range(.Cells(3, 1), .Cells(.Rows.Count, 1)).Resize(, 50).ClearContents
End With
For n = 1 To 3 'Name; Nr; Art
NewWS.Cells(3, n).Resize(myDic(n).Count) = .Transpose(myDic(n).items)
Next n
' .Cells(3, 4).Resize(myDic(4).Count).FormulaR1C1 = .Transpose(myDic(4).items) 'Summe
For n = 4 To 50 'Monate Jan bis Dez und Sonst...
NewWS.Cells(3, n).Resize(myDic(n).Count) = .Transpose(myDic(n).items)
Next n
NewWS.Cells(1, 1).Resize(, 50).EntireColumn.AutoFit 'auto optimale Spaltenbreite
NewWS.EnableCalculation = True
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub