Sub
Uebertrag_AlleMontagefirma()
Dim
loAnz
As
Long
, loLetzte
As
Long
Dim
raBereich
As
Range, raZelle
As
Range
Dim
lngCalc
As
Long
Application.ScreenUpdating =
False
lngCalc = Application.Calculation
Application.Calculation = xlCalculationManual
With
Worksheets(
"Montagefirma"
)
.Range(
"A1:xfd"
& .Cells(.Rows.Count, 1).
End
(xlUp).Row).Clear
End
With
With
Worksheets(
"Terminplan"
)
.Columns(
"A:B"
).Hidden =
False
Set
raBereich = .Range(
"B1:B"
& .Cells(.Rows.Count,
"B"
).
End
(xlUp).Row)
For
Each
raZelle
In
raBereich.SpecialCells(xlCellTypeVisible)
If
raZelle.Text = Worksheets(
"Montage Firmen"
).Range(
"b2"
).Text
Or
raZelle.Text = .Range(
"b3"
).Text _
Or
raZelle.Text = .Range(
"b4"
).Text
Or
raZelle.Text = .Range(
"b5"
).Text
Or
raZelle.Text = .Range(
"b6"
).Text _
Or
raZelle.Text = .Range(
"b7"
).Text
Or
raZelle.Text = .Range(
"b8"
).Text
Or
raZelle.Text = .Range(
"b9"
).Text _
Or
raZelle.Text = .Range(
"b10"
).Text
Or
raZelle.Text = .Range(
"b11"
).Text
Or
raZelle.Text = .Range(
"b12"
).Text
Then
raZelle.EntireRow.SpecialCells(xlCellTypeVisible).Copy
loAnz = loAnz + 1
With
Worksheets(
"Montagefirma"
)
loLetzte = .Cells(.Rows.Count,
"A"
).
End
(xlUp).Offset(1).Row
If
.Cells(1,
"A"
) =
""
Then
loLetzte = 1
.Cells(loLetzte,
"A"
).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(loLetzte,
"A"
).PasteSpecial Paste:=xlPasteFormats
End
With
End
If
Application.CutCopyMode =
False
Next
raZelle
.Columns(
"A:B"
).Hidden =
True
End
With
Application.Calculation = lngCalc
MsgBox
"Es wurden "
& loAnz &
" Sätze übertragen."
Set
raBereich =
Nothing
End
Sub