День добрый! Написал небольшую раскраску, на основе готового макроса из РуНета:
[vba]
Код
Dim ra As Range, cell As Range, res, txt$, v, pos& On Error Resume Next: Err.Clear
' Линия БОПП Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП Range("O9:V9").Font.Color = 0
Set ra = Range("O9:V9") ' диапазон для поиска ' минимальный отход res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0) Цвет = -11489280 ' зеленный ' процедура раскраски текста txt$ = Trim(res) For Each cell In ra.Cells ' перебираем все ячейки pos = 1 If cell.Text Like "*" & txt & "*" Then arr = Split(cell.Text, txt, , vbTextCompare) ' разбивает текст ячейки на части If UBound(arr) > 0 Then ' если подстрока найдена For Each v In arr ' перебираем все вхождения pos = pos + Len(v) ' начальная позиция With cell.Characters(pos, Len(txt)) .Font.Color = Цвет ' выделяем цветом End With pos = pos + Len(txt) Next v End If End If Next cell
' максимальный отход res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0) Цвет = -16777024 ' красный
' процедура раскраски текста txt$ = Trim(res) For Each cell In ra.Cells ' перебираем все ячейки pos = 1 If cell.Text Like "*" & txt & "*" Then arr = Split(cell.Text, txt, , vbTextCompare) ' разбивает текст ячейки на части If UBound(arr) > 0 Then ' если подстрока найдена For Each v In arr ' перебираем все вхождения pos = pos + Len(v) ' начальная позиция With cell.Characters(pos, Len(txt)) .Font.Color = Цвет ' выделяем цветом End With pos = pos + Len(txt) Next v End If End If Next cell
[/vba]
Как мне выделить в отдельное место кода эту процедуру раскраски, чтоб не плодить много букв кода ? То есть определил в диапазоне макс значение, вызвал процедуру, раскрасил, далее ищем минимальное значение и снова раскраска текста ?
Вот примерный скелет кода, но переменные не передает ((( [vba]
Код
' Линия БОПП Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП Range("O9:V9").Font.Color = 0
Set ra = Range("O9:V9") ' диапазон для поиска ' минимальный отход res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0) Цвет = -11489280 ' зеленный
Call процедура_раскраски_текста
res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0) Цвет = -16777024 ' красный
Call процедура_раскраски_текста
' и так далее ....
[/vba]
День добрый! Написал небольшую раскраску, на основе готового макроса из РуНета:
[vba]
Код
Dim ra As Range, cell As Range, res, txt$, v, pos& On Error Resume Next: Err.Clear
' Линия БОПП Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП Range("O9:V9").Font.Color = 0
Set ra = Range("O9:V9") ' диапазон для поиска ' минимальный отход res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0) Цвет = -11489280 ' зеленный ' процедура раскраски текста txt$ = Trim(res) For Each cell In ra.Cells ' перебираем все ячейки pos = 1 If cell.Text Like "*" & txt & "*" Then arr = Split(cell.Text, txt, , vbTextCompare) ' разбивает текст ячейки на части If UBound(arr) > 0 Then ' если подстрока найдена For Each v In arr ' перебираем все вхождения pos = pos + Len(v) ' начальная позиция With cell.Characters(pos, Len(txt)) .Font.Color = Цвет ' выделяем цветом End With pos = pos + Len(txt) Next v End If End If Next cell
' максимальный отход res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0) Цвет = -16777024 ' красный
' процедура раскраски текста txt$ = Trim(res) For Each cell In ra.Cells ' перебираем все ячейки pos = 1 If cell.Text Like "*" & txt & "*" Then arr = Split(cell.Text, txt, , vbTextCompare) ' разбивает текст ячейки на части If UBound(arr) > 0 Then ' если подстрока найдена For Each v In arr ' перебираем все вхождения pos = pos + Len(v) ' начальная позиция With cell.Characters(pos, Len(txt)) .Font.Color = Цвет ' выделяем цветом End With pos = pos + Len(txt) Next v End If End If Next cell
[/vba]
Как мне выделить в отдельное место кода эту процедуру раскраски, чтоб не плодить много букв кода ? То есть определил в диапазоне макс значение, вызвал процедуру, раскрасил, далее ищем минимальное значение и снова раскраска текста ?
Вот примерный скелет кода, но переменные не передает ((( [vba]
Код
' Линия БОПП Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП Range("O9:V9").Font.Color = 0
Set ra = Range("O9:V9") ' диапазон для поиска ' минимальный отход res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0) Цвет = -11489280 ' зеленный
Call процедура_раскраски_текста
res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0) Цвет = -16777024 ' красный
Sub процедура_раскраски_текста(res, ra As Range, Цвет) Dim cell As Range Dim txt$ Dim v, pos& On Error Resume Next: Err.Clear ' процедура раскраски текста txt$ = Trim(res) For Each cell In ra.Cells ' перебираем все ячейки pos = 1 If cell.Text Like "*" & txt & "*" Then arr = Split(cell.Text, txt, , vbTextCompare) ' разбивает текст ячейки на части If UBound(arr) > 0 Then ' если подстрока найдена For Each v In arr ' перебираем все вхождения pos = pos + Len(v) ' начальная позиция With cell.Characters(pos, Len(txt)) .Font.Color = Цвет ' выделяем цветом End With pos = pos + Len(txt) Next v End If End If Next cell End Sub
[/vba] [vba]
Код
Sub macr() Dim ra As Range, res ' Линия БОПП Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП Range("O9:V9").Font.Color = 0
Set ra = Range("O9:V9") ' диапазон для поиска ' минимальный отход res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0) Цвет = -11489280 ' зеленный
Call процедура_раскраски_текста(res, ra, Цвет)
res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0) Цвет = -16777024 ' красный
Call процедура_раскраски_текста(res, ra, Цвет)
' и так далее ....
End Sub
[/vba]
Передавать нужно типа такого: [vba]
Код
Sub процедура_раскраски_текста(res, ra As Range, Цвет) Dim cell As Range Dim txt$ Dim v, pos& On Error Resume Next: Err.Clear ' процедура раскраски текста txt$ = Trim(res) For Each cell In ra.Cells ' перебираем все ячейки pos = 1 If cell.Text Like "*" & txt & "*" Then arr = Split(cell.Text, txt, , vbTextCompare) ' разбивает текст ячейки на части If UBound(arr) > 0 Then ' если подстрока найдена For Each v In arr ' перебираем все вхождения pos = pos + Len(v) ' начальная позиция With cell.Characters(pos, Len(txt)) .Font.Color = Цвет ' выделяем цветом End With pos = pos + Len(txt) Next v End If End If Next cell End Sub
[/vba] [vba]
Код
Sub macr() Dim ra As Range, res ' Линия БОПП Range("O9:V9") = Range("B36:I36").Value ' Линия БОПП Range("O9:V9").Font.Color = 0
Set ra = Range("O9:V9") ' диапазон для поиска ' минимальный отход res = Application.Round(Application.WorksheetFunction.Min(Range("B30:I30")), 0) Цвет = -11489280 ' зеленный
Call процедура_раскраски_текста(res, ra, Цвет)
res = Application.Round(Application.WorksheetFunction.Max(Range("B30:I30")), 0) Цвет = -16777024 ' красный