Option
Explicit
Sub
Mein_Übertrag_Montagefirma()
Dim
rngU
As
Range
Dim
rngB
As
Range
Dim
rngT
As
Range
Dim
loAnz
As
Long
Dim
loLetzte
As
Long
Application.ScreenUpdating =
False
With
Worksheets(
"Montagefirma"
)
.Range(
"A1:AA"
& .Cells(.Rows.Count, 1).
End
(xlUp).Row).Clear
End
With
With
Worksheets(
"Terminplan"
)
.Columns(
"A:B"
).Hidden =
False
Set
rngU = Range(.Cells(1), .Cells(.Cells.Find(
"*"
, _
.Cells(1), -4123, 2, 1, 2,
False
).Row, _
.Cells.Find(
"*"
, .Cells(1), -4123, 2, 2, 2,
False
).Column))
For
Each
rngB
In
rngU.Columns(
"B"
).Cells
If
rngB.Text = .Range(
"F6"
).Text
Then
loAnz = loAnz + 1
Set
rngT = rngU.Rows(rngB.Row)
Set
rngT = rngT.Offset(, 2).Resize(, rngT.Columns.Count - 2)
rngT.Copy
With
Worksheets(
"Montagefirma"
)
If
.Cells(1) =
""
Then
loLetzte = 1
Else
loLetzte = .Cells.Find(
"*"
, .Cells(1), -4123, 2, 1, 2,
False
).Row + 1
End
If
.Cells(loLetzte,
"A"
).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(loLetzte,
"A"
).PasteSpecial Paste:=xlPasteFormats
End
With
End
If
Next
rngB
Application.CutCopyMode =
False
.Columns(
"A:B"
).Hidden =
True
End
With
MsgBox
"Es wurden "
& loAnz &
" Sätze übertragen."
Application.ScreenUpdating =
True
End
Sub