vba подкраска строк из настройки

vba-Подкраска строк из настройки.vba

'Данный модуль позволяет производить подкраску диапазонов по совпадающей фразе.
'Настройки должны выглядеть следующим образом:

'a - строка с которой начинается перебор для поиска
'b - столбец, который является идентификатором цикла
'c - столбец в котором происходит сравнение
'd - фраза сравнения
'e - диапазон
'f - цвет в системе excel 2003

'a&b&c;d&e&f

'Допустимо использовать символ * для разделения нескольких условий сравнения:
'a&b&c;d&e&f*d&e&f

'Допустимо использовать несколько настроек подкрашивания:
'a&b&c;d&e&f*d&e&f|a&b&c;d&e&f*d&e&f

'ВАЖНО! Каждая настройка каждый раз заново сканирует книгу.

'Запрещенные символы: [&][;][*][|]

'В диапазоне номер строки заменяется символом [_]

'Пример:
''3&53&52;Ошибка&A_:AZ_&22*Верно&A_:AZ_&40'

'В данном примере:
'3		- строка с которой начинается перебор
'53		- стоблец по которому идет перебор пока значение Cells(3, 53) <> ""
'52		- столбец в котором ищется совпадающее значение
'Ошибка  - совпадающее значение
'A_:AZ_  - диапазон подкрашивания
'22		- код цвета excel 2003 vba
'Верно	- второе совпадающее значение
'A_:AZ_  - диапазон подкрашивания
'40		- код цвета excel 2003 vba

Option Explicit

Public Sub executePaintRange(keyForFind As String)
    Dim propertiesText As String
    propertiesText = Properties.getProperties(keyForFind)
    Call execute(propertiesText)
End Sub

Private Sub execute(propertiesText As String)
    Dim arrayTreatment As Variant
    arrayTreatment = getArray(propertiesText, "|")
    Dim i As Integer
    Dim text As String
    For i = LBound(arrayTreatment) To UBound(arrayTreatment)
        text = Trim(arrayTreatment(i))
        Call executePaint(text)
    Next i
End Sub

Private Function getArray(propertiesText As String, delimeter As String) As Variant
    Dim arr As Variant
    arr = Split(propertiesText, delimeter)
    getArray = arr
End Function

Private Sub executePaint(paintInstruction As String)
    Dim arrayProp As Variant
    Dim text As String
    arrayProp = getArray(paintInstruction, ";")
    Dim arrColumnAndRow As Variant
    text = arrayProp(0)
    arrColumnAndRow = getArray(text, "&")
    Dim arrPainter As Variant
    text = arrayProp(1)
    text = Trim(text)
    Call Util.writeLog(text)
    Call executePaintRow(arrColumnAndRow, text)
End Sub

Private Sub executePaintRow(arrColumnAndRow As Variant, propPaint As String)
    Dim text As String
    text = arrColumnAndRow(0)
    Dim rowWhile As Long
    rowWhile = CLng(text)
    Dim columnWhile As Long
    text = arrColumnAndRow(1)
    columnWhile = CLng(text)
    Dim columnCheckPaint As Long
    text = arrColumnAndRow(2)
    columnCheckPaint = CLng(text)

    Dim arrPaint As Variant
    arrPaint = getArray(propPaint, "*")

    Dim replaceRange As String
    Do While Cells(rowWhile, columnWhile) <> ""
        Dim i As Integer
        Dim arrExecute As Variant
        For i = LBound(arrPaint) To UBound(arrPaint)
            text = arrPaint(i)
            arrExecute = getArray(text, "&")
            Dim textCheck As String
            text = arrExecute(0)
            textCheck = LCase(text)
            Dim rangePaint As String
            text = Trim(arrExecute(1))
            rangePaint = text
            Dim color As String
            text = Trim(arrExecute(2))
            color = CDbl(text)
            If (LCase(Cells(rowWhile, columnCheckPaint)) = LCase(textCheck)) Then
                replaceRange = Replace(rangePaint, "_", CStr(rowWhile))
                Range(replaceRange).Interior.colorIndex = color
            End If
        Next i
        rowWhile = rowWhile + 1
    Loop
End Sub