Вставка строк и форматирование. Модифицировать макрос.

[LuNa]

Добрый вечер всем.
Можно я задам вопрос тут, мне кажется, что по этой же теме )))
у меня уже есть макрос который вставляет пустые строки по условию - при изменении данных в столбце 4 и формулу туда:

Код: Выделить всё

Sheets("Лист1").Select
        With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        iLastRow = Cells(Rows.Count, 4).End(xlUp).Row
          If iLastRow = 1 Then
            MsgBox "Нет данных в столбце E!", vbExclamation, "Oшибка"
            Exit Sub
        End If
            For i = iLastRow To 4 Step -1
                If Cells(i, 4) <> Cells(i - 1, 4) Then
                    Cells(i, 4).EntireRow.Insert
                    Cells(i, 1).FormulaR1C1 = "=VLOOKUP(R[1]C[3],ХХХ!R29C42:R45C43,2,FALSE)"
                    i = i - 1
                End If
            Next i
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Мне необходимо его дополнить: шрифт в строке которую вставляют чтобы был например красный курсив и голубая заливка в ячейках этой строки с 1 по 5 столбец

[Naeel Maqsudov]

Перед i=i-1

Код: Выделить всё

         With Range(Cells(i,1),Cells(i,5))
             .Font. … шрифт со всеми его свойствами (ставим точку, смотрим подстрочник)
             .Interior. … оформление ячейки
         End With

Но я бы всё переписал.

1) Я бы не делал Sheets("Лист1").Select, а обращался бы к ячейкам на нужном листе Sheets("Лист1").Cels…

2) Вставку формулы и форматирование можно вынести из цикла, обратившись сразу к прямоугольному диапазону.

[pashulka]

Для решения подобных задач можно также использовать свойство .Resize которое, правда, учитывает наличие об'единённых ячеек.

Код: Выделить всё

Private Sub Test()
    Dim iLastRow&, iRow&
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        With .Worksheets("Лист1")
             iLastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
             If iLastRow = 1 Then
                MsgBox "Нет данных в столбце D!", vbExclamation, "Oшибка"
                Exit Sub
             End If
             For iRow = iLastRow To 4 Step -1
                 If .Cells(iRow, 4) <> .Cells(iRow - 1, 4) Then
                    .Cells(iRow, 4).EntireRow.Insert 'Or .Rows(iRow).Insert
                    With .Cells(iRow, 1)
                         .FormulaR1C1 = "=VLOOKUP(R[1]C[3],ХХХ!R29C42:R45C43,2,FALSE)"
                         .Font.ColorIndex = 3
                         .Font.Italic = True
                         .Resize(, 5).Interior.ColorIndex = 33
                    End With
                    iRow = iRow - 1
                 End If
             Next
        End With
        .Calculation = xlAutomatic
        .ScreenUpdating = True
    End With
End Sub

[LuNa]

Счастье есть!!!! Огромное всем спасибо! Пригодились оба ответа