Gruppe
Allgemein
Problem
Die Werte aus den Spalten A:B sollen in neue Tabellenblätter kopiert und nach Gruppen bis 100, > 100 bis 1000, > 1000 bis 10000, > 10000 bis 100000 und über 100000 aufgeteilt werden. Für jede Gruppe soll ein einzelnes Tabellenblatt angelegt werden.
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