Доброго всем времени, уважаемые!!!! Накропал тут небольшой макрос для окрашивания определенного количества ячеек в строке при внесении в ячейку любого значения.
[vba]
Код
Dim PR As Long Dim PC As Long Dim dl As Long Dim dr As Long Dim ds As Long
Private Sub Worksheet_Change(ByVal Target As Range) PR = Cells(Rows.Count, 2).End(xlUp).Row PC = Cells.SpecialCells(xlLastCell).Column If Not Intersect(Target, Range(Cells(1, 3), Cells(PR, PC))) Is Nothing Then If Target.Count > 1 Then Exit Sub dl = Target.Row ds = Target.Column dr = Range("B" & dl).Value If ds - 2 < dr Then dr = ds - 2 Else: dr = dr End If If Target <> "" Then Target.Offset(0, -dr + 1).Resize(1, dr).Select With Selection.Interior .Color = 65535 End With End If
End Sub
[/vba]
а вот как сделать, что бы при удалении этого значения из ячейки окрашивание удалялось что то никак не получается.
[p.s.]как всегда критика приветствуется и , при наличии времени, комментарии желательны
Доброго всем времени, уважаемые!!!! Накропал тут небольшой макрос для окрашивания определенного количества ячеек в строке при внесении в ячейку любого значения.
[vba]
Код
Dim PR As Long Dim PC As Long Dim dl As Long Dim dr As Long Dim ds As Long
Private Sub Worksheet_Change(ByVal Target As Range) PR = Cells(Rows.Count, 2).End(xlUp).Row PC = Cells.SpecialCells(xlLastCell).Column If Not Intersect(Target, Range(Cells(1, 3), Cells(PR, PC))) Is Nothing Then If Target.Count > 1 Then Exit Sub dl = Target.Row ds = Target.Column dr = Range("B" & dl).Value If ds - 2 < dr Then dr = ds - 2 Else: dr = dr End If If Target <> "" Then Target.Offset(0, -dr + 1).Resize(1, dr).Select With Selection.Interior .Color = 65535 End With End If
End Sub
[/vba]
а вот как сделать, что бы при удалении этого значения из ячейки окрашивание удалялось что то никак не получается.
[p.s.]как всегда критика приветствуется и , при наличии времени, комментарии желательны китин
Я когда сам файл посмотрел - понял, что диапазон... Так тогда возникает вопрос - а у какой именно части этого диапазона надо убрать раскрашивание? Ну или если надо убрать "всё влево пока раскрашенное" - так цикл с убиранием, что-то по типу такого:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) PR = Cells(Rows.Count, 2).End(xlUp).Row PC = Cells.SpecialCells(xlLastCell).Column If Not Intersect(Target, Range(Cells(1, 3), Cells(PR, PC))) Is Nothing Then If Target.Count > 1 Then Exit Sub dl = Target.Row ds = Target.Column dr = Range("B" & dl).Value If ds - 2 < dr Then dr = ds - 2 Else dr = dr If Target <> "" Then Target.Offset(0, -dr + 1).Resize(1, dr).Interior.Color = 65535 Else Set cell = Target While cell.Column > 2 And cell.Value = "" And cell.Interior.Color = 65535 cell.Interior.Color = xlNone Set cell = cell.Offset(, -1) Wend End If End If End Sub
[/vba]
Я когда сам файл посмотрел - понял, что диапазон... Так тогда возникает вопрос - а у какой именно части этого диапазона надо убрать раскрашивание? Ну или если надо убрать "всё влево пока раскрашенное" - так цикл с убиранием, что-то по типу такого:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) PR = Cells(Rows.Count, 2).End(xlUp).Row PC = Cells.SpecialCells(xlLastCell).Column If Not Intersect(Target, Range(Cells(1, 3), Cells(PR, PC))) Is Nothing Then If Target.Count > 1 Then Exit Sub dl = Target.Row ds = Target.Column dr = Range("B" & dl).Value If ds - 2 < dr Then dr = ds - 2 Else dr = dr If Target <> "" Then Target.Offset(0, -dr + 1).Resize(1, dr).Interior.Color = 65535 Else Set cell = Target While cell.Column > 2 And cell.Value = "" And cell.Interior.Color = 65535 cell.Interior.Color = xlNone Set cell = cell.Offset(, -1) Wend End If End If End Sub
Private Sub Worksheet_Change(ByVal Target As Range) PR = Cells(Rows.Count, 2).End(xlUp).Row PC = Cells.SpecialCells(xlLastCell).Column If Not Intersect(Target, Range(Cells(1, 3), Cells(PR, PC))) Is Nothing Then If Target.Count > 1 Then Exit Sub dl = Target.Row ds = Target.Column dr = Range("B" & dl).Value If ds - 2 < dr Then dr = ds - 2 End If If Target <> "" Then Target.Offset(0, -dr + 1).Resize(1, dr).Interior.Color = 65535 Else For i = 0 To dr - 1 If Target.Offset(0, -i) <> "" Then Exit Sub Target.Offset(0, -i).Interior.Pattern = xlNone Next i End If End If End Sub
[/vba]
Игорь, а зачем ты Димонов наверх, до Саба, вынес? Ты их потом еще где-то использовать собираешься? А отступы очень удобно делать Тав-ом. И еще кнопочка специальная есть (ПКМ на панель в VBA, вылезает менюшка, выбираешь "Ити ты", появляется панель (примерно как в 2003 было) А то очень неудобно с таким кодом работать
Такой вариант [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) PR = Cells(Rows.Count, 2).End(xlUp).Row PC = Cells.SpecialCells(xlLastCell).Column If Not Intersect(Target, Range(Cells(1, 3), Cells(PR, PC))) Is Nothing Then If Target.Count > 1 Then Exit Sub dl = Target.Row ds = Target.Column dr = Range("B" & dl).Value If ds - 2 < dr Then dr = ds - 2 End If If Target <> "" Then Target.Offset(0, -dr + 1).Resize(1, dr).Interior.Color = 65535 Else For i = 0 To dr - 1 If Target.Offset(0, -i) <> "" Then Exit Sub Target.Offset(0, -i).Interior.Pattern = xlNone Next i End If End If End Sub
[/vba]
Игорь, а зачем ты Димонов наверх, до Саба, вынес? Ты их потом еще где-то использовать собираешься? А отступы очень удобно делать Тав-ом. И еще кнопочка специальная есть (ПКМ на панель в VBA, вылезает менюшка, выбираешь "Ити ты", появляется панель (примерно как в 2003 было) А то очень неудобно с таким кодом работать_Boroda_
зачем ты Димонов наверх, до Саба, вынес? Ты их потом еще где-то использовать собираешься?
Не знаю. Я пробовал отдельный макрос для удаления цвета написать с теми же переменными, но не получилось совместить. Всем спасибо, все отлично работает!!!!
зачем ты Димонов наверх, до Саба, вынес? Ты их потом еще где-то использовать собираешься?
Не знаю. Я пробовал отдельный макрос для удаления цвета написать с теми же переменными, но не получилось совместить. Всем спасибо, все отлично работает!!!!китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Вообще, если уж строго подходить, то надо использовать код примерно так:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range(Cells(1, 3), Cells(Cells(Rows.Count, 2).End(xlUp).Row, Cells.SpecialCells(xlLastCell).Column))) Is Nothing Then Exit Sub
Set cell = Target Do While cell.Column > 2 And (Target.Column - cell.Column) < Cells(Target.Row, 2) If Target.Value <> "" Then cell.Interior.Color = 65535 Else If cell.Value = "" And cell.Interior.Color = 65535 Then cell.Interior.Color = xlNone Else Exit Do End If End If Set cell = cell.Offset(, -1) Loop End Sub
[/vba]
Вообще, если уж строго подходить, то надо использовать код примерно так:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range(Cells(1, 3), Cells(Cells(Rows.Count, 2).End(xlUp).Row, Cells.SpecialCells(xlLastCell).Column))) Is Nothing Then Exit Sub
Set cell = Target Do While cell.Column > 2 And (Target.Column - cell.Column) < Cells(Target.Row, 2) If Target.Value <> "" Then cell.Interior.Color = 65535 Else If cell.Value = "" And cell.Interior.Color = 65535 Then cell.Interior.Color = xlNone Else Exit Do End If End If Set cell = cell.Offset(, -1) Loop End Sub