klaro geht das ...
13.11.2013 19:23:18
Matthias
Hallo
Sub Kopieren()
Dim lngLZeile As Long
Dim rngZelle As Range
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Tabelle1")
lngLZeile = .Cells(Rows.Count, 21).End(xlUp).Row
For Each rngZelle In .Range("F2:F" & lngLZeile).SpecialCells(xlCellTypeBlanks)
rngZelle.Value = .Cells(rngZelle.Row, 2).Value
.Cells(rngZelle.Row, 2).Copy
rngZelle.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
.Cells(rngZelle.Row, 2).Interior.ColorIndex = rngZelle.Interior.ColorIndex
Next rngZelle
End With
End Sub
Sub entfernen()
Dim lngLZeile As Long
Dim rngZelle As Range
With ThisWorkbook.Sheets("Tabelle1")
lngLZeile = .Cells(Rows.Count, 21).End(xlUp).Row
For Each rngZelle In .Range("B2:B" & lngLZeile).SpecialCells(xlCellTypeConstants)
If rngZelle.Value = .Cells(rngZelle.Row, 6).Value Then
.Cells(rngZelle.Row, 6).ClearContents
.Cells(rngZelle.Row, 6).ClearFormats
End If
Next rngZelle
End With
End Sub
Gruß Matthias