Gruppe
Matrix
Problem
Wie kann ich Werte nach zwei Kriterien summieren? Sowohl die Funktion ZÄHLENWENN als auch SUMMEWENN akzeptieren nur ein Kriterium.
StandardModule: basMain
Sub NachWertKopieren()
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim rng As Range
Dim arr(1 To 4) As Double
Dim iCounter As Integer, iRow As Integer, iCount As Integer
Application.ScreenUpdating = False
Set wksSource = ActiveSheet
arr(1) = 100
arr(2) = 1000
arr(3) = 10000
arr(4) = 100000
For iCounter = 1 To 5
If iCounter = 1 Then
wksSource.Range("A1").AutoFilter Field:=2, _
Criteria1:="<=" & CStr(arr(iCounter))
ElseIf iCounter < 5 Then
wksSource.Range("A1").AutoFilter Field:=2, _
Criteria1:=">" & CStr(arr(iCounter - 1)), _
Operator:=xlAnd, Criteria2:="<=" & _
CStr(arr(iCounter))
Else
wksSource.Range("A1").AutoFilter Field:=2, _
Criteria1:=">" & CStr(arr(iCounter - 1))
End If
iCount = WorksheetFunction.Subtotal(2, _
wksSource.Range("A1").CurrentRegion)
If iCount > 0 Then
Set rng = wksSource.Range("A1").CurrentRegion _
.SpecialCells(xlCellTypeVisible)
On Error Resume Next
Set wksTarget = Worksheets(wksSource _
.AutoFilter.Filters(2).Criteria1)
If Err > 0 Or wksTarget Is Nothing Then
Err.Clear
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = _
wksSource.AutoFilter.Filters(2).Criteria1
rng.Copy Range("A3")
Rows(3).Delete
Else
iRow = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
rng.Copy wksTarget.Cells(iRow, 1)
wksTarget.Rows(iRow).Delete
End If
On Error GoTo 0
End If
Next iCounter
wksSource.Select
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub