RAN, Может поиграться с блоками в строке, которые нужно красить и окраске их разом? потом только посмотрел, что гоняется макрос по всему столбцу.
ну и обновление экрана придушить обязательно.
Frosted.one, если изменений всего в одной строке, то ваш код запускается по всему столбцу, что и является самым большим тормозом.
нет ни ограничения по области данных, да и проверять то нужно только в строках где значения изменились, а остальные строки не трогать.
Скрытый текст |
---|
Код |
---|
Sub COLOR(Rng As Range)
' Dim Rng As Range
Dim n
Dim rData
Application.ScreenUpdating = False
'Dim RndMY
With Rng.Parent
' Set Rng = .Range("G:G")
For Each n In Rng
Select Case n
Case "сущ"
For i = 1 To 58
If Cells(n.Row, i).Interior.ColorIndex = xlNone Then Cells(n.Row, i).Interior.ColorIndex = 0
Next
Case "план"
For i = 1 To 58
If Cells(n.Row, i).Interior.ColorIndex = xlNone Then Cells(n.Row, i).Interior.ColorIndex = 19
Next
Case "откл"
For i = 1 To 58
If Cells(n.Row, i).Interior.ColorIndex = xlNone Then Cells(n.Row, i).Interior.ColorIndex = 15
Next
End Select
Next n
End With
Application.ScreenUpdating = True
End Sub |
Код |
---|
If Not Intersect(Target, Range("G:G")) Is Nothing Then
Call COLOR(Intersect(Target, Range("G:G")))
End If |
|
А лучше
Скрытый текст |
---|
Код |
---|
Sub COLOR(Rng As Range)
Dim C As Long
Application.ScreenUpdating = False
For Each n In Rng
C = -1
Select Case n
Case "сущ"
C = 0
Case "план"
C = 19
Case "откл"
C = 15
End Select
If C >= 0 Then
For Each Mycell In Rng.Parent.Cells(n.Row, 1).Resize(, 58)
If Mycell.Interior.ColorIndex = xlNone Then Mycell.Interior.ColorIndex = C
Next
End If
Next n
Application.ScreenUpdating = True
End Sub
|
|