---

Sub Razdelenie_LIC_ALAE()

    ' Переменные
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim i As Long
    Dim j As Long
    Dim newRow As Long
    Dim resultRows As Long
    Dim amount As Double

    Dim data As Variant
    Dim result As Variant

    ' Ускоряем Excel
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' Исходный лист
    Set ws = ThisWorkbook.Worksheets("LIC ALAE")

    ' Удаляем старый лист результата, если он существует
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("LIC ALAE результат").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    ' Создаём новый лист
    Set newWs = ThisWorkbook.Worksheets.Add(After:=ws)
    newWs.Name = "LIC ALAE результат"

    ' Находим размеры исходных данных
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' Загружаем все данные в память
    data = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value

    ' Сначала считаем, сколько строк будет в результате
    resultRows = 1

    For i = 2 To lastRow

        If LCase(Trim(data(i, 6))) = "прочее" _
           And IsNumeric(data(i, 4)) _
           And data(i, 4) <> "" Then

            resultRows = resultRows + 2

        Else

            resultRows = resultRows + 1

        End If

    Next i

    ' Создаём массив результата
    ReDim result(1 To resultRows, 1 To lastCol)

    ' Заголовки
    For j = 1 To lastCol
        result(1, j) = data(1, j)
    Next j

    newRow = 2

    ' Формируем результат в памяти
    For i = 2 To lastRow

        ' Если "прочее"
        If LCase(Trim(data(i, 6))) = "прочее" _
           And IsNumeric(data(i, 4)) _
           And data(i, 4) <> "" Then

            amount = data(i, 4)

            ' ОСАГО Физ — 87%
            For j = 1 To lastCol
                result(newRow, j) = data(i, j)
            Next j

            result(newRow, 1) = "ОСАГО Физ"
            result(newRow, 4) = amount * 0.87

            newRow = newRow + 1

            ' ОСАГО Юр — 13%
            For j = 1 To lastCol
                result(newRow, j) = data(i, j)
            Next j

            result(newRow, 1) = "ОСАГО Юр"
            result(newRow, 4) = amount * 0.13

            newRow = newRow + 1

        Else

            ' Остальные строки копируем как есть
            For j = 1 To lastCol
                result(newRow, j) = data(i, j)
            Next j

            newRow = newRow + 1

        End If

    Next i

    ' Одним действием записываем весь результат на лист
    newWs.Range( _
        newWs.Cells(1, 1), _
        newWs.Cells(resultRows, lastCol) _
    ).Value = result

    ' Автоширина
    newWs.Columns.AutoFit

    ' Возвращаем настройки Excel
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    MsgBox "Готово! Создан лист: LIC ALAE результат"

End Sub