Private
Sub
Worksheet_Change(
ByVal
Target
As
Range)
Dim
Start&, Zeilen#, OldCalc#
On
Error
GoTo
EvOn
If
Target.Address =
"$I$4"
Then
If
Target.Value = vbNullString
Then
Exit
Sub
With
Application
OldCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents =
False
.ScreenUpdating =
False
.DisplayAlerts =
False
End
With
If
MsgBox(
"Spalte I mit dem Kriterium "
& Target.Value &
" unwiderruflich löschen?"
, _
vbYesNo + vbCritical) = vbNo
Then
MsgBox
"Löschung abgebrochen!"
& vbLf &
"Kriterium wird gelöscht!"
Target = vbNullString
Else
Start = Timer
Range(
"J6"
) =
"Dummy"
Range(
"J7"
) = 1
With
Range(
"J7:J150006"
)
.DataSeries
.CurrentRegion.Sort Range(
"I7"
), Header:=xlYes
End
With
Range(
"I6:I150006"
).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=Range(
"K1:K2"
), Unique:=
False
Zeilen = Range(
"7:150006"
).SpecialCells(xlCellTypeVisible).Rows.Count
Range(
"7:1048576"
).SpecialCells(xlCellTypeVisible).Delete
Me
.ShowAllData
With
Range(
"J6:J150006"
)
.CurrentRegion.Sort Range(
"J7"
), Header:=xlYes
.ClearContents
End
With
Target = vbNullString
Application.ScreenUpdating =
True
MsgBox
"Es wurden "
& Format(Zeilen,
"#,##0"
) &
" Datensätze von 150.000 gelöscht!"
& vbLf & _
"Die Aktion dauerte "
& Format(Timer - Start,
"0.00 sec."
)
End
If
End
If
EvOn:
With
Application
.EnableEvents =
True
.Calculation = OldCalc
.ScreenUpdating =
True
.DisplayAlerts =
True
End
With
End
Sub