Option
Explicit
Sub
ausschneiden()
Dim
intRow
As
Integer
, intLastRow
As
Integer
Dim
ASH
As
Worksheet, gesamt
As
Worksheet, unbetrachtet
As
Worksheet
Dim
x
As
Long
, y
As
Long
, lngZeilen
As
Long
Dim
rngZelle
As
Range
Dim
lngAnz
As
Long
Dim
V1, V2
Dim
NWB
As
Workbook
With
ThisWorkbook
Set
ASH = .ActiveSheet
Set
gesamt = .Worksheets(
"Gesamtauszug"
)
End
With
For
Each
rngZelle
In
ThisWorkbook.ActiveSheet.UsedRange
If
rngZelle.HasFormula =
True
Then
rngZelle.Rows.Delete
lngAnz = lngAnz + 1
End
If
Next
rngZelle
lngZeilen = gesamt.Cells(gesamt.Rows.Count, 1).
End
(xlUp).Row
x = 1
Set
NWB = Workbooks.Add
With
NWB
Set
unbetrachtet = .Sheets(1)
.Sheets(1).Name =
"unbetrachtete Datensätze"
Application.DisplayAlerts =
False
.Sheets(2).Delete
.Sheets(2).Delete
Application.DisplayAlerts =
True
End
With
For
y = 2
To
lngZeilen
With
gesamt
V1 = .Cells(y, 10)
V2 = .Cells(y, 3).Value
End
With
If
Not
V1
Like
"W*"
_
Or
V2
Like
"ROTES*"
_
Or
V2
Like
"TANKK*"
_
Or
V2
Like
"EZW*"
_
Or
V2
Like
"FREMD*"
Then
gesamt.Rows(y).Cut unbetrachtet.Rows(x)
x = x + 1
End
If
Next
y
With
NWB
.SaveAs ThisWorkbook.Path &
"\Unbetrachtet.xls"
End
With
With
ASH
intLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For
intRow = intLastRow
To
1
Step
-1
If
Application.CountA(.Rows(intRow)) = 0
Then
intLastRow = intLastRow - 1
Else
Exit
For
End
If
Next
intRow
For
intRow = intLastRow
To
1
Step
-1
If
IsEmpty(.Cells(intRow, 10))
Then
.Rows(intRow).Delete
End
If
Next
intRow
End
With
End
Sub