Private Sub Worksheet_Change(ByVal Target As Range)
Dim tRow As Long
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
tRow = WorksheetFunction.Match(Target, Range("D:D"), 0)
Range("D" & tRow).Copy
Target.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Application.EnableEvents = True
End If
Sub ApplyFormats()
Dim LastRColA As Long
Dim LastRColD As Long
Dim MatchRng As Range
Dim Counter As Long
Dim CopyFromRng As Range
Dim CopyToRng As Range
With ThisWorkbook.Worksheets("Sheet1")
LastRColA = .Cells(.Rows.Count, "a").End(xlUp).Row
LastRColD = .Cells(.Rows.Count, "d").End(xlUp).Row
Set MatchRng = .Range("a1:a" & LastRColA)
With .Range("d1:d" & LastRColD)
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
End With
For Counter = 1 To LastRColD
Set CopyToRng = .Cells(Counter, "d")
If CopyToRng <> 0 Then
On Error Resume Next
Set CopyFromRng = .Cells(Application.Match(CopyToRng.Value, MatchRng, 0), "a")
If Err = 0 Then
CopyFromRng.Copy
CopyToRng.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Else
Err.Clear
End If
On Error GoTo 0
End If
Next
End With
MsgBox "Done"
End Sub
Thanks Bill