Option
Explicit
Sub
uebertrag()
Application.ScreenUpdating =
False
Const
Tabelle1 =
"Datenbank "
Const
Tabelle3 =
"Ziel"
Dim
i
As
Integer
Dim
iAnz
As
Integer
Dim
letzte
As
Long
Worksheets(
"Ziel"
).Activate
letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Worksheets(
"Ziel"
).Range(
"A1:AA"
& letzte).Clear
Worksheets(
"Datenbank "
).Range(
"A18:AM18"
).Copy
Worksheets(
"Ziel"
).Activate
Range(
"A3"
).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
False
Worksheets(
"Ziel"
).Range(
"A4"
).Activate
Sheets(Tabelle1).Activate
Range(
"A4"
).
Select
iAnz = 0
i = 0
Do
Until
i = ActiveSheet.UsedRange.Rows.Count
If
ActiveCell.Value =
"x"
Then
Selection.EntireRow.Copy
Sheets(Tabelle3).Activate
ActiveSheet.Paste
ActiveCell.Offset(1, 0).
Select
Sheets(Tabelle1).
Select
ActiveCell.Offset(1, 0).
Select
iAnz = iAnz + 1
Else
ActiveCell.Offset(1, 0).
Select
End
If
i = i + 1
Loop
MsgBox
"Es wurde "
& iAnz &
" Satz übertragen"
Application.CutCopyMode =
False
Application.ScreenUpdating =
True
End
Sub