VBA - вставить объединенную строку между пробелами в данных

Question

В настоящее время у меня есть макрос, который вставляет 3 строки при изменении значения в столбце E (курс курса).В 3 рядах я пытаюсь объединить средний ряд и добавить отдел в этот ряд.Я не могу понять, как заставить его слиться, любая помощь будет оценена.

With Range("e" & myHeader + 2, Range("e" & Rows.Count).End(xlUp)).Offset(, 1)
.Formula = _
"=if(and(r[-1]c[-1]<>"""",rc[-1]<>"""",r[-1]c[-1]<>rc[-1])," & _
"if(r[-1]c=1,""a"",1),"""")"
.Value = .Value
On Error Resume Next
For i = 1 To 3
    .SpecialCells(2, 1).EntireRow.Insert
    .SpecialCells(2, 2).EntireRow.Insert
Next

Вот как это сейчас:

Это то, что я хотел быиметь:

Answer 1

В приведенном ниже столбце E кодового цикла импортируйте три строки при изменении значения, объедините столбец A в столбец E, импортируйте и отформатируйте значение в средней строке.

Попробуйте:

Option Explicit

Sub test()

    Dim i As Long, Lastrow As Long
    Dim Department  As String, NextDepartment As String

    With ThisWorkbook.Worksheets("Sheet1")
        Lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row

        For i = Lastrow To 2 Step -1
            Department = .Range("E" & i).Value
            NextDepartment = .Range("E" & i).Offset(-1, 0).Value
            If Department <> NextDepartment Then
                .Rows(i).EntireRow.Resize(3).Insert
                .Range("A" & i + 1 & ":E" & i + 1).Merge
                With .Range("A" & i + 1)
                    .Value = Department
                    .Font.Bold = True
                    .HorizontalAlignment = xlLeft
                    .VerticalAlignment = xlCenter
                End With
            End If
        Next i

    End With

Вывод:

Answer 2

При вставке или удалении строк работайте снизу вверх.Для вставки трех строк, объединения ячеек и передачи значений должно быть достаточно простого смещения и изменения размера.

Option Explicit

Sub insertDept3()

    Dim i As Long

    With Worksheets("sheet10")
        For i = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 To 1 Step -1
            If .Cells(i, "E").Value <> .Cells(i + 1, "E").Value Or i = 1 Then
                .Cells(i + 1, "A").Resize(3, 5).Insert shift:=xlDown
                .Cells(i + 2, "A").Resize(1, 5).Merge
                .Cells(i + 2, "A") = .Cells(i + 4, "E").Value
            End If
        Next i
    End With

End Sub

Я оставлю вам выравнивание ячеек и форматирование шрифта.