Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Werte nach Kriterien prüfen und auf Blätter verteilen

Gruppe

Kopieren

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.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

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