AW: @Nepumuk : Aber warum ALLE Werte ?
12.12.2009 17:33:39
ransi
HAllo
In der "Urschleimversion" gab es bis die auf die Zellen in denen summiert werden sollte keine leeren Zellen.
Genau dafür war der Code geschrieben.
Jetzt sind zusätzliche leere Zellen im Listenbereich dazu gekommen. Da muss man natürlich nacharbeiten.
Einfach vor dem Einfügen der Suumewenn() abfragen ob die Zelle leer ist. Wenn ja-->Summewenn() wenn nein -->Nix machen
Dann wird auch nichts mehr überschrieben.
Option Explicit
Sub VariableSpalten()
Dim Arr As Variant, lngLS As Long, lngS As Long
Dim rngBereich As Range, rngPSP As Range
Dim L As Long
lngS = Application.Match("Budget", Rows("14:14"), 0) - 5 'Sucht "Budget" in Zeile 15
lngLS = Cells(14, Columns.Count).End(xlToLeft).Column
Set rngPSP = Range("C15").CurrentRegion.Offset(1).Resize(10000, 1)
Set rngBereich = Range("C15").CurrentRegion.Offset(1).Resize(10000, lngLS - 1)
Arr = rngBereich
For L = 1 To UBound(Arr)
If Arr(L, 3 + lngS) = "" Then
If Arr(L, 3 + lngS) = "" Then Arr(L, 3 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("E15:E10000").Offset(, lngS))
If Arr(L, 4 + lngS) = "" Then Arr(L, 4 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("F15:F10000").Offset(, lngS))
If Arr(L, 5 + lngS) = "" Then Arr(L, 5 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("G15:G10000").Offset(, lngS))
If Arr(L, 6 + lngS) = "" Then Arr(L, 6 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("H15:H10000").Offset(, lngS))
If Arr(L, 3 + lngS) = 0 Then Arr(L, 3 + lngS) = ""
If Arr(L, 4 + lngS) = 0 Then Arr(L, 4 + lngS) = ""
If Arr(L, 5 + lngS) = 0 Then Arr(L, 5 + lngS) = ""
If Arr(L, 6 + lngS) = 0 Then Arr(L, 6 + lngS) = ""
End If
Next
'Range("C15:H10000") = Arr
rngBereich = Arr
End Sub
ransi