Makro kürzer u. schneller ?

Guten Abend,
ich habe für das Filtern der Daten u. die entsprechende Anzahl
in eine Zelle folgendes Makro gefertigt:


Sub Auszählen()
Application.ScreenUpdating = False
Range("A5:AC5").Select
If Not ActiveSheet.AutoFilterMode Then
Selection.AutoFilter
End If
Selection.AutoFilter Field:=13, Criteria1:="216"
ActiveSheet.Range("A4").Select
Selection.Copy
ActiveSheet.Range("AH1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Exit Sub
Selection.AutoFilter Field:=13, Criteria1:="21601"
ActiveSheet.Range("A4").Select
Selection.Copy
Range("AH2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFilter Field:=13, Criteria1:="21603"
ActiveSheet.Range("A4").Select
Selection.Copy
ActiveSheet.Range("AH3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFilter Field:=13, Criteria1:="21604"
ActiveSheet.Range("A4").Select
Selection.Copy
ActiveSheet.Range("AH4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFilter Field:=13, Criteria1:="21605"
ActiveSheet.Range("A4").Select
Selection.Copy
ActiveSheet.Range("AH5").Select
' ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
If ActiveSheet.AutoFilterMode Then
Selection.AutoFilter
End If
'  ActiveSheet.Range("AG1:AI5").Select
'   ActiveSheet.PageSetup.PrintArea = "$AG$1:$AI$5"
'   ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ActiveSheet.Range("C3").Select
Application.ScreenUpdating = True
End Sub

Kann man das Makro auch kürzer u. vielleicht schneller gestalten, da jedesmal ja Filter gesetzt
wird etc. dauert etwas`?
herzlichen Abendgruß Kurt aus K

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Auszählen() Dim A As Long Dim FilterBereich As Range Dim FilterKrit As String Application.ScreenUpdating = False With ActiveSheet Set FilterBereich = .Range("A5:AC5") For A = 1 To 5 If A = 1 Then FilterKrit = "216" ElseIf A = 2 Then FilterKrit = "21601" ElseIf A = 2 Then FilterKrit = "21603" ElseIf A = 2 Then FilterKrit = "21604" Else FilterKrit = "21605" End If FilterBereich.AutoFilter Field:=13, Criteria1:=FilterKrit .Cells(A, 34).Value = .Range("A4").Value Next A FilterBereich.AutoFilter End With Application.ScreenUpdating = True End Sub

Sub Auszählen() Dim A As Long Dim FilterBereich As Range Dim FilterKrit As String Application.ScreenUpdating = False With ActiveSheet Set FilterBereich = .Range("A5:AC" & Cells.SpecialCells(xlCellTypeLastCell).Row) If Not .FilterMode Then FilterBereich.AutoFilter End If For A = 1 To 5 If A = 1 Then FilterKrit = "216" ElseIf A = 2 Then FilterKrit = "21601" ElseIf A = 3 Then FilterKrit = "21603" ElseIf A = 4 Then FilterKrit = "21604" Else FilterKrit = "21605" End If FilterBereich.AutoFilter Field:=13, Criteria1:=FilterKrit .Cells(A, 34).Value = .Range("A4").Value Next A End With FilterBereich.AutoFilter Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread