---

Option Explicit

Sub SPLIT_LIC_CLAIM()

    ' =========================================================
    ' ПЕРЕМЕННЫЕ
    ' =========================================================
    
    Dim ws As Worksheet
    Dim newWs As Worksheet
    Dim wsMain As Worksheet
    
    Dim lastRow As Long
    Dim lastCol As Long
    Dim lastUgRow As Long
    
    Dim i As Long
    Dim j As Long
    Dim newRow As Long
    Dim resultRows As Long
    
    Dim amount As Double
    Dim physicalPercent As Double
    Dim legalPercent As Double
    
    Dim data As Variant
    Dim result As Variant
    
    Dim ugDict As Object
    Dim key As String


    ' =========================================================
    ' УСКОРЯЕМ РАБОТУ EXCEL
    ' =========================================================
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False


    ' =========================================================
    ' ИСХОДНЫЕ ЛИСТЫ
    ' =========================================================
    
    Set ws = ThisWorkbook.Worksheets("LIC CLAIM INPUT")
    Set wsMain = ThisWorkbook.Worksheets("LIC CLAIM MAIN")


    ' =========================================================
    ' УДАЛЯЕМ СТАРЫЙ LIC CLAIM
    ' =========================================================
    
    On Error Resume Next
    ThisWorkbook.Worksheets("LIC CLAIM").Delete
    On Error GoTo 0


    ' =========================================================
    ' СОЗДАЁМ НОВЫЙ LIC CLAIM
    ' =========================================================
    
    Set newWs = ThisWorkbook.Worksheets.Add(After:=ws)
    newWs.Name = "LIC CLAIM"


    ' =========================================================
    ' БЕРЁМ ПРОЦЕНТЫ ИЗ LIC CLAIM MAIN
    ' A2 = Физ
    ' B2 = Юр
    ' =========================================================
    
    physicalPercent = wsMain.Range("A2").Value
    legalPercent = wsMain.Range("B2").Value


    ' =========================================================
    ' ПРОВЕРЯЕМ, ЧТО ПРОЦЕНТЫ ДАЮТ 100%
    ' =========================================================
    
    If Abs(physicalPercent + legalPercent - 1) > 0.000001 Then
        
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Application.EnableEvents = True
        
        MsgBox "Ошибка: проценты в LIC CLAIM MAIN!A2 и B2 не дают 100%."
        Exit Sub
        
    End If


    ' =========================================================
    ' ОПРЕДЕЛЯЕМ РАЗМЕР ИСХОДНОЙ ТАБЛИЦЫ
    ' =========================================================
    
    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


    ' =========================================================
    ' СОЗДАЁМ СЛОВАРЬ:
    ' НОВЫЕ АЛЬ → УГ
    ' =========================================================
    
    Set ugDict = CreateObject("Scripting.Dictionary")
    
    ' Последняя строка таблицы соответствий в LIC CLAIM MAIN
    lastUgRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row
    
    ' Таблица соответствий начинается с 8-й строки
    For i = 8 To lastUgRow
        
        key = Trim(CStr(wsMain.Cells(i, "A").Value))
        
        If key <> "" Then
            ugDict(key) = wsMain.Cells(i, "B").Value
        End If
        
    Next i


    ' =========================================================
    ' СЧИТАЕМ КОЛИЧЕСТВО СТРОК В РЕЗУЛЬТАТЕ
    ' =========================================================
    
    resultRows = 1
    ' Первая строка — заголовки
    
    For i = 2 To lastRow
        
        ' Если в D есть число — делаем две строки
        If IsNumeric(data(i, 4)) _
           And data(i, 4) <> "" Then
            
            resultRows = resultRows + 2
            
        Else
            
            ' Если D не число — оставляем одну строку
            resultRows = resultRows + 1
            
        End If
        
    Next i


    ' =========================================================
    ' СОЗДАЁМ МАССИВ РЕЗУЛЬТАТА
    ' +1 СТОЛБЕЦ ДЛЯ УГ
    ' =========================================================
    
    ReDim result(1 To resultRows, 1 To lastCol + 1)


    ' =========================================================
    ' КОПИРУЕМ ЗАГОЛОВКИ
    ' =========================================================
    
    For j = 1 To lastCol
        result(1, j) = data(1, j)
    Next j
    
    ' Новый последний столбец
    result(1, lastCol + 1) = "УГ"
    
    ' Первая строка данных
    newRow = 2


    ' =========================================================
    ' ФОРМИРУЕМ РЕЗУЛЬТАТ
    ' =========================================================
    
    For i = 2 To lastRow
        
        
        ' =====================================================
        ' ЕСЛИ В D ЕСТЬ ЧИСЛО — ДЕЛИМ НА ФИЗ И ЮР
        ' =====================================================
        
        If IsNumeric(data(i, 4)) _
           And data(i, 4) <> "" Then
            
            ' Сохраняем исходную сумму
            amount = data(i, 4)
            
            
            ' =================================================
            ' ОСАГО_Физ
            ' =================================================
            
            For j = 1 To lastCol
                result(newRow, j) = data(i, j)
            Next j
            
            ' Меняем А
            result(newRow, 1) = "ОСАГО_Физ"
            
            ' Сумма Физ
            result(newRow, 4) = amount * physicalPercent
            
            ' Ищем УГ для ОСАГО_Физ
            key = Trim(CStr(result(newRow, 1)))
            
            If ugDict.Exists(key) Then
                result(newRow, lastCol + 1) = ugDict(key)
            End If
            
            newRow = newRow + 1
            
            
            ' =================================================
            ' ОСАГО_Юр
            ' =================================================
            
            For j = 1 To lastCol
                result(newRow, j) = data(i, j)
            Next j
            
            ' Меняем А
            result(newRow, 1) = "ОСАГО_Юр"
            
            ' Сумма Юр
            result(newRow, 4) = amount * legalPercent
            
            ' Ищем УГ для ОСАГО_Юр
            key = Trim(CStr(result(newRow, 1)))
            
            If ugDict.Exists(key) Then
                result(newRow, lastCol + 1) = ugDict(key)
            End If
            
            newRow = newRow + 1
            
            
        ' =====================================================
        ' ЕСЛИ D НЕ ЧИСЛО — ПРОСТО КОПИРУЕМ СТРОКУ
        ' =====================================================
        
        Else
            
            For j = 1 To lastCol
                result(newRow, j) = data(i, j)
            Next j
            
            ' Проверяем УГ для исходного значения A
            key = Trim(CStr(result(newRow, 1)))
            
            If ugDict.Exists(key) Then
                result(newRow, lastCol + 1) = ugDict(key)
            End If
            
            newRow = newRow + 1
            
        End If
        
    Next i


    ' =========================================================
    ' ВЫГРУЖАЕМ ВЕСЬ РЕЗУЛЬТАТ НА НОВЫЙ ЛИСТ
    ' =========================================================
    
    newWs.Range( _
        newWs.Cells(1, 1), _
        newWs.Cells(resultRows, lastCol + 1) _
    ).Value = result


    ' =========================================================
    ' АВТОШИРИНА СТОЛБЦОВ
    ' =========================================================
    
    newWs.Columns.AutoFit


    ' =========================================================
    ' ВОЗВРАЩАЕМ НАСТРОЙКИ EXCEL
    ' =========================================================
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True


    ' =========================================================
    ' ГОТОВО
    ' =========================================================
    
    MsgBox "ГОТОВО!"

End Sub