Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim celColor As Range, rgCalendars As Range, targ As Range
Dim i As Long, j As Long
Set rgCalendars = Union([A5:G9], [I5:O9], [Q5:W9], [A13:G17], [I13:O17], [Q13:W17], _
[A21:G25], [I21:O25], [Q21:W25], [A29:G33], [I29:O33], [Q29:W33])
Set targ = Intersect(Target, rgCalendars)
If targ Is Nothing Then Exit Sub
Cancel = True
On Error Resume Next
Set celColor = Application.InputBox("Please click on the cell with color you want to copy", Type:=8)
On Error GoTo 0
If Not celColor Is Nothing Then
targ.Interior.Color = celColor.Interior.Color
End If
End Sub
|