Sub S_Sicherung()
Dim shSource As Worksheet, shTarget As Worksheet
Dim FirstCell As Range
Dim CurrCell As Range
Dim rng6 As Range
Set shSource = Sheets("BH12-BH20")
Set shTarget = Sheets("U3_MA_NSHV")
With Application.FindFormat
.Clear
.Interior.ColorIndex = 6
End With
With shSource.Columns(10)
Set FirstCell = .Find(What:="", After:=.Cells(.Cells.Count), SearchFormat:=True)
If Not FirstCell Is Nothing Then
Set CurrCell = FirstCell
Do
If Not rng6 Is Nothing Then
Set rng6 = Union(rng6, CurrCell)
Else
Set rng6 = CurrCell
End If
Set CurrCell = .Cells.Find(What:="", After:=CurrCell, SearchFormat:=True)
Loop Until CurrCell.Address = FirstCell.Address
End If
End With
Application.FindFormat.Clear
rng6.Copy
With shTarget
Set FirstCell = .Range(rng6.Cells(1).Offset(37).Address)
FirstCell.PasteSpecial xlPasteValues
End With
End Sub