Dim curColor&, PreviousColor&, PreviousCell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Âûäåëåíèå ÿ÷åéêè If Not PreviousCell Is Nothing Then PreviousCell.Interior.Color = PreviousColor& If Target.Count > 1 Then Exit Sub If Not Intersect(Range("B:B"), Target) Is Nothing Then curColor = Target.Interior.Color Target.Interior.ColorIndex = 5 PreviousColor& = curColor: Set PreviousCell = Target End If End Sub
[/vba]
Так? [vba]
Код
Dim curColor&, PreviousColor&, PreviousCell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Âûäåëåíèå ÿ÷åéêè If Not PreviousCell Is Nothing Then PreviousCell.Interior.Color = PreviousColor& If Target.Count > 1 Then Exit Sub If Not Intersect(Range("B:B"), Target) Is Nothing Then curColor = Target.Interior.Color Target.Interior.ColorIndex = 5 PreviousColor& = curColor: Set PreviousCell = Target End If End Sub
Они не стираются - а заливаются белым цветом. Можно так: [vba]
Код
Dim curColor&, PreviousColor&, PreviousCell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Выделение ячейки If Not PreviousCell Is Nothing Then If PreviousColor& = "16777215" Then PreviousCell.Interior.Pattern = xlNone Else PreviousCell.Interior.Color = PreviousColor& If Target.Count > 1 Then Exit Sub If Not Intersect(Range("B:B"), Target) Is Nothing Then curColor = Target.Interior.Color Target.Interior.ColorIndex = 5 PreviousColor& = curColor: Set PreviousCell = Target End If End Sub
[/vba]
Они не стираются - а заливаются белым цветом. Можно так: [vba]
Код
Dim curColor&, PreviousColor&, PreviousCell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Выделение ячейки If Not PreviousCell Is Nothing Then If PreviousColor& = "16777215" Then PreviousCell.Interior.Pattern = xlNone Else PreviousCell.Interior.Color = PreviousColor& If Target.Count > 1 Then Exit Sub If Not Intersect(Range("B:B"), Target) Is Nothing Then curColor = Target.Interior.Color Target.Interior.ColorIndex = 5 PreviousColor& = curColor: Set PreviousCell = Target End If End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Выделение ячейки Dim rng1 As Range If bufAdr <> "" Then Range(bufAdr).Interior.Color = bufColor If Target.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub
bufAdr = Target.Address bufColor = Target.Interior.Color Target.Interior.ColorIndex = 5 End Sub
[/vba]
Или вариация [vba]
Код
Dim bufColor As Long Dim bufAdr As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Выделение ячейки Dim rng1 As Range If bufAdr <> "" Then Range(bufAdr).Interior.Color = bufColor If Target.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub
bufAdr = Target.Address bufColor = Target.Interior.Color Target.Interior.ColorIndex = 5 End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Выделение ячейки Dim rng1 As Range If bufAdr <> "" Then If bufColor = "16777215" Then Range(bufAdr).Interior.Pattern = xlNone Else Range(bufAdr).Interior.Color = bufColor End If End If If Target.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub
bufAdr = Target.Address bufColor = Target.Interior.Color Target.Interior.ColorIndex = 5 End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Выделение ячейки Dim rng1 As Range If bufAdr <> "" Then If bufColor = "16777215" Then Range(bufAdr).Interior.Pattern = xlNone Else Range(bufAdr).Interior.Color = bufColor End If End If If Target.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub
bufAdr = Target.Address bufColor = Target.Interior.Color Target.Interior.ColorIndex = 5 End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub On Error Resume Next Columns("B:B").FormatConditions(1).Delete 'Columns("B:B").FormatConditions.Delete 'Для 2003 Target.FormatConditions.Add Type:=xlExpression, Formula1:="=1" Target.FormatConditions(1).Interior.ColorIndex = 5 End Sub
[/vba] Если нужно для 2003 Excel, то там аналогично, но
Еще такой вариант условным форматированием [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub On Error Resume Next Columns("B:B").FormatConditions(1).Delete 'Columns("B:B").FormatConditions.Delete 'Для 2003 Target.FormatConditions.Add Type:=xlExpression, Formula1:="=1" Target.FormatConditions(1).Interior.ColorIndex = 5 End Sub
[/vba] Если нужно для 2003 Excel, то там аналогично, но_Boroda_