Изменить цвет в слове

[valerij]

Сообщение от Igor67

И у меня код рабочий

Да я и не сомневаюсь!!! Вот плохой из меня писака, Игорь прав.
Разберемся, возьмем начало и конец макроса

Sub Macro_Tovar()
    Dim iPrices(1 To 41, 1 To 1), iRow&, iLL As Long
             For iLL = 1 To 9
    iPrices(1, 1) = "Хл. Домашний Кру"      '1 Домашний Кру
    iPrices(2, 1) = "Хл. Пшенич. Фор."      '2 Хл. Пшеничный Фор.
    iPrices(3, 1) = "Хл. Бородино     УП"   '3 Хл. Бородино
    iPrices(4, 1) = "Хл. Бородино"          '4 Хл. Бородино
    iPrices(5, 1) = "Хл. Украинский   УП"   '5 Хл. Украинский
    iPrices(6, 1) = "Хл. Украинский"        '6 Хл. Украинский
..................................................................................
    iPrices(40, 1) = "Хл. Домашний Кру"     '40 Хл. Домашний Кру
    iPrices(41, 1) = "xxxxxxxxxx"                 '41 Для резерва
             For iRow = 3 To 1623 Step 54
                With Sheets(iLL).Cells
                    .Cells(iRow, 3).Resize(41).Value = iPrices
                End With
            Next
        Next
End Sub

Задача:
Нужно вписать эти имена на 9 листах, в яч. С3 :С43 с шагом 54.
В случае, если в этих именах встретится слово УП, окрасить УП.
Т. Е. действие сразу, проверяет на УП -вписавает, проверяет на УП -вписавает + окрашивает
Ну и зачем изобретать еще макросы, если, уверен, можно все сделать тут, но я ненаю, как.
Почему, так не работает

For iRow = 3 To 543 Step 54
             With Sheets(iLL).Cells
                 .Cells(iRow, 3).Resize(41).Value = iPrices
                 p = InStr(.Cells(iRow, 3), "УП")
              If p > 0 Then
                 .Cells(iRow, 3).Characters(Start:=p, Length:=2).Font
                     .FontStyle = "bold"
                      .Color = -16776961
              End If
            End With
        Next

[Igor67]

ИМХО, пока Вы не внесете данные в ячейку, то и не сможете ее обработать.
У Вас идет групповая операция - Вы присваиваете значение массива диапазону ячеек, а вот редактировать необходимо 1 ячейку. Поэтому, возможно меня и поправят, лучше будет Вам сначала значения присвоить, а уже потом пробежаться поиском и покрасить Ваш УП

[valerij]

Сообщение от Igor67

ИМХО, пока Вы не внесете данные в ячейку, то и не сможете ее обработать.

Да, согласен, вот так, все получилось, ошибка была, красным

For iRow = 3 To 543 Step 54
           With Sheets(iLL).Cells
          .Cells(iRow, 3).Resize(41).Value = iPrices
    End With
 Next
        For r = 3 To 43
            p = InStr(iPrices(r - 2, 1), "УП")
                If p > 0 Then
            With Cells(r, 3).Characters(Start:=p, Length:=2).Font
                .FontStyle = "bold"
                .Color = -16776961
            End With
                End If
        Next

[Igor67]

Была ошибка, вчера не досмотрел. Совпало последняя строка с нужными данными. Добавил проверку и выход из Do при отсутствии значений...

Sub TestKrasim()
Dim iSht As Worksheet
Dim iFoundRng As Range, firstAddress As String, findData As String, p As Integer

Dim iRow As Long

findData = "УП"


Application.ScreenUpdating = False

For Each iSht In ThisWorkbook.Sheets
' If iSht.Name <> iShtRplData.Name Then
With iSht
Set iFoundRng = .Columns(3).Find(What:=findData, LookIn:=xlValues, LookAt:=xlPart) 'поиск
If Not iFoundRng Is Nothing Then 'если нашли
iRow = iFoundRng.Row
p = InStr(iFoundRng, findData)

With iFoundRng.Characters(Start:=p, Length:=2).Font
.FontStyle = "bold"
.Color = -16776961
End With

Do 'цикл поиска, т.к. одно и то же значение может встречаться много раз
Set iFoundRng = .Range(.Cells(iRow + 1, 3), .Cells(.Cells(Rows.Count, 3).End(xlUp).Row, 3)).Find(What:=findData, LookIn:=xlValues, LookAt:=xlPart) 'продолжаем поиск на том же листе
If iFoundRng Is Nothing Then Exit Do 'если больше ничего нет выход из цикла
iRow = iFoundRng.Row
p = InStr(iFoundRng, findData)

With iFoundRng.Characters(Start:=p, Length:=2).Font
.FontStyle = "bold"
.Color = -16776961
End With
Loop While iRow <> .Cells(Rows.Count, 3).End(xlUp).Row
End If
End With


Next

Application.ScreenUpdating = True
MsgBox "Замена по листам проведена!", 64, "Замена"
End Sub

[valerij]

Сообщение от Igor67

Добавил проверку и выход из Do при отсутствии значений...

А теперь посмотри как я сам сделал, все работает по всем 9 листам, а полный, готовый модуль в аттаче

        With Sheets(iLL)
            For iRow = 3 To 1623 Step 54
                    .Cells(iRow, 3).Resize(41).Value = iPrices
            Next
1:      For r = 3 + m To 43 + m
                p = InStr(Cells(r, 3), "УП")
            If p > 0 Then
                With .Cells(r, 3).Characters(Start:=p, Length:=2).Font
                    .FontStyle = "bold"
                    .Color = -16776961
                End With
            End If
        Next
            If m = 1620 Then GoTo 2
                m = m + 54: GoTo 1
2: End With

[Igor67]

Если Вас все устраивает - рад за Вас.
ИМХО самая "медленная" операция в Ехс - обращение к ячейке. Ваш вариант просто просматривает каждую ячейку из 1500, и потом выполняет действие. В этом случае Find будет будет несколько быстрее