Option
Explicit
Option
Compare Text
Sub
Daten_uebertragen()
ActiveSheet.Unprotect Password:=
"xxxxxxxx"
Dim
i
As
Long
, iOutzeile
As
Long
, iAnz
As
Integer
Application.ScreenUpdating =
False
Worksheets(
"Datenbank"
).Range(
"A18:AM18"
).Copy
ActiveSheet.Unprotect Password:=
"xxxxxxxx"
Worksheets(
"Ziel"
).Activate
Range(
"A3"
).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
False
Worksheets(
"Ziel"
).Range(
"A4"
).Activate
iOutzeile = 4
With
Sheets(
"Datenbank"
)
For
i = 4
To
.UsedRange.Rows.Count
If
.Cells(i,
"A"
).Value
Like
"x"
Then
Sheets(
"Ziel"
).Rows(iOutzeile).Value = .Rows(i).Value
iOutzeile = iOutzeile + 1
iAnz = iAnz + 1
End
If
Next
i
End
With
Application.ScreenUpdating =
True
MsgBox
"Habe "
& iAnz & IIf(iAnz = 1,
" Satz"
,
" Sätze"
) &
" übertragen"
, vbInformation,
"Daten übertragen"
ActiveSheet.Protect Password:=
"xxxxxxxx"
Tabelle7.Visible = xlSheetVisible
End
Sub