MyTetra Share
Делитесь знаниями!
Набор диапазона(закрасить ячейки диапазона по условию)
Время создания: 22.06.2021 14:28
Текстовые метки: range, cell, ColorIndex, Interior, Color
Раздел: !Закладки - VBA - Excel - Range
Запись: adgaver/mytetra_base_New/master/base/16243612941lz90nttcp/text.html на raw.githubusercontent.com

Sub run_Interior_ColorIndex()

Dim oSh As Worksheet

Set oSh = ThisWorkbook.Sheets("Data")

With oSh

Lng_RowsEnd = .Cells(65256, 1).End(xlUp).Row

Range(.Cells(2, 1), .Cells(Lng_RowsEnd, 24)).Interior.Color = xlNone

End With


Call Interior_ColorIndex_Type(oSh:=oSh, strVal:="qqqq", Lng_ColorIndex:=15, Lng_ClnCheck:=15, Lng_ClnStart:=1, Int_ClnEnd:=24)


End Sub

Sub Interior_ColorIndex_Type( _

ByVal oSh As Worksheet, _

ByVal strVal As String, _

ByVal Lng_ColorIndex As Long, _

ByVal Lng_ClnCheck As Long, _

ByVal Lng_ClnStart As Long, _

ByVal Int_ClnEnd As Long)


iCountMod = 5000


Dim rRange As Range

With oSh

Lng_RowsEnd = .Cells(65256, 1).End(xlUp).Row

ar = Range(.Cells(2, Lng_ClnCheck), .Cells(Lng_RowsEnd, Lng_ClnCheck)).Value


For i = LBound(ar) To UBound(ar) ' цикл по строкам диапазона

If Trim(ar(i, 1)) = strVal Then ' если ячейка диапазона...

If rRange Is Nothing Then ' диапазон еще пустой

Set rRange = Range(.Cells(i + 1, Lng_ClnStart), .Cells(i + 1, Int_ClnEnd)) ' формируем диапазон

Else

Set rRange = Union(rRange, Range(.Cells(i + 1, Lng_ClnStart), .Cells(i + 1, Int_ClnEnd))) ' пополняем диапазон

End If

End If


If (i Mod iCountMod) = 0 Then

rRange.Interior.ColorIndex = Lng_ColorIndex

DoEvents

'Stop

Set rRange = Nothing

End If


Next i

End With


rRange.Interior.ColorIndex = Lng_ColorIndex


End Sub


.Interior.Color = vbRed

.Interior.Color = RGB(255, 0, 0)

.Interior.Color = 255

'Работа с объектами листа медленная. Если ячеек много и заливать нужно не целым диапазоном, можно обработать в памяти и залить ячейки одной командой.


Sub PaintCells()

Dim r1 As Range, r2 As Range

Dim c As Range

Set r1 = Range("A1:C10") ' диапазон в переменную

r1.Interior.Pattern = xlNone ' убираем заливку

' r1.Interior.ColorIndex = 0 ' или так


For Each c In r1 ' цикл по ячейкам диапазона

If c.Value = 25 Then ' если условие выполняется

If r2 Is Nothing Then ' диапазон еще пустой

Set r2 = c ' формируем диапазон

Else

Set r2 = Union(r2, c) ' пополняем диапазон

End If

End If

Next c


If Not r2 Is Nothing Then r2.Interior.Color = 255 ' заливаем

Set r1 = Nothing: Set r2 = Nothing ' освобождаем память

End Sub

'Залить строки по условию в ячейке:


For i = 1 To r1.Rows.Count ' цикл по строкам диапазона

If r1(i, 1).Value = 25 Then ' если левая ячейка диапазона...

If r2 Is Nothing Then ' диапазон еще пустой

Set r2 = Range(Cells(i, 1), Cells(i, 3)) ' формируем диапазон

Else

Set r2 = Union(r2, Range(Cells(i, 1), Cells(i, 3))) ' пополняем диапазон

End If

End If

Next i


 
MyTetra Share v.0.55
Яндекс индекс цитирования