Sub Uebertrag_AlleMontagefirmaAAA()
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("MontagefirmenAlle")
.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 Not Worksheets("Montage Firmen").Range("B2:B12").Find( _
What:=raZelle.Text, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
MatchByte:=False _
) Is Nothing Then
raZelle.EntireRow.SpecialCells(xlCellTypeVisible).Copy
loAnz = loAnz + 1
With Worksheets("MontagefirmenAlle")
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