=E6&" - "&G6&", "&D6&", "&C6

 Application.Wait Time:=Now + TimeValue("0:00:05")

=ИНДЕКС($D$2:$D$6;ПОИСКПОЗ(КОНМЕСЯЦА(A2;-1)+1;$C$2:$C$6;0);1)

Sub mrshkei()
Dim i As Long, j As Long, lr As Long, cell As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A2:G" & lr): col = UBound(arr, 2) - LBound(arr) + 1
x = Application.WorksheetFunction.SumIf(Range("A2:G" & lr).Offset(1, 1), ">0", Range("A2:G" & lr).Offset(1, 1)) + 1
ReDim arr2(1 To x, 1 To col): k = 2
For i = 1 To col: arr2(k - 1, i) = arr(1, i): Next i
For i = LBound(arr) + 1 To UBound(arr)
    For j = 2 To col
        If arr(i, j) > 0 Then
            For jj = 1 To arr(i, j)
                arr2(k, 1) = arr(i, 1)
                    For n = 2 To col
                        If n <> j Then
                            arr2(k, n) = 0
                        Else
                            arr2(k, n) = 1
                        End If
                    Next n
                k = k + 1
            Next jj
        End If
    Next j
Next i
Range("S2").Resize(UBound(arr2), col) = arr2
End Sub

Sub mrshkei()
Dim i As Long, n As Long, k As Long, lr As Long, col As New Collection, sh As Worksheet, sh2 As Worksheet, j As Long, j2 As Long
Set sh = ActiveSheet
Application.ScreenUpdating = False
k = 7 'начало строк с данными
lr = Cells(Rows.Count, 2).End(xlUp).Row 'посл. строка
For i = k To lr
    On Error Resume Next
    col.Add sh.Cells(i, 2).Interior.ColorIndex, CStr(sh.Cells(i, 2).Interior.ColorIndex)
Next i
Sheets.Add
With ActiveSheet
Set sh2 = ActiveSheet
    .Name = Replace(Date, "-", "-")
j = 1

For n = 1 To col.Count
j2 = j
    For i = k To lr
        If sh.Cells(i, 2).Interior.ColorIndex = CDbl(col(n)) Then
        sh.Range(sh.Cells(i, 2), sh.Cells(i, 14)).Copy Destination:=.Cells(j, 1)
        j = j + 1
        End If
    Next i
    
        '.Range(.Cells(j2, 1), .Cells(j - 1, 13)).Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
        "A" & j2 & ":A" & j - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A" & j2 & ":M" & j - 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Next n
sh.Activate
.Range("A1:M" & j - 1).Copy
sh.Cells(k, 2).Select
ActiveSheet.Paste
End With
Application.DisplayAlerts = False
sh2.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

lr = sh.Application.WorksheetFunction.Count(sh.Range("C3:C100000"))

lr = sh.Application.WorksheetFunction.CountA(sh.Range("C3:C100000"))

Sub meshkei()
Dim i As Long, n As Long, lr As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 2 Step -1
    If Cells(i, 7) = "Да" And Cells(i, 7) <> "" Then
        Rows(i + 1 & ":" & i + 1).Insert
        For n = 1 To 12
            If n <> 8 Then
                Range(Cells(i, n), Cells(i + 1, n)).Merge
            Else
            Cells(i, n).NumberFormat = "dd/mm/yyyy Дата протокола"
             Cells(i + 1, n).NumberFormat = "dd/mm/yyyy Дата подписания"
            End If
        Next n
    End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub ÄîáàâèòüÏðîä()
Dim sh As Worksheet, sh2 As Worksheet, lr As Long, i As Long, k As Long, x As Long
Set sh = Worksheets("Ðååñòð ïðîäàæ"): Set sh2 = Worksheets("Ïðîäàæè")
Application.ScreenUpdating = False
With sh2
k = Application.WorksheetFunction.CountIf(.Columns(16), "a")
If k = 0 Then
MsgBox "Ôîðìà ââîäà íå çàïîëíåíà!", vbCritical, "Îøèáêà çàïèñè"
Exit Sub
End If
Worksheets("Ðååñòð ïðîäàæ").Unprotect Password:=""
    lr2 = .Cells(Rows.Count, 15).End(xlUp).Row
    For i = 7 To lr2
    lr = sh.Application.WorksheetFunction.Count(sh.Range("C3:C100000"))
    If lr = 0 Then lr = 3 Else lr = lr + 3
        If .Cells(i, 16) = "a" Then
            sh.Rows(lr & ":" & lr).Insert
            .Range("C" & i & ":O" & i).Copy
            sh.Cells(lr, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next i
End With
sh.Activate
ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True
Application.ScreenUpdating = True
End Sub

Sub mrshkei()
    Dim arr, arr2, arr3, arr4, i As Long, j As Long, n As Long, lr As Long
    Dim col As New Collection
    
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("A2:B" & lr)
    
    For i = LBound(arr) To UBound(arr)
    arr2 = Split(arr(i, 2), ",")
        For j = LBound(arr2) To UBound(arr2)
            On Error Resume Next
            col.Add Trim(arr2(j)), CStr(Trim(arr2(j)))
        Next j
    Next i
    ReDim arr3(1 To col.Count, 1 To 3)
    For i = 1 To col.Count
    arr3(i, 1) = col(i)
        For j = LBound(arr) To UBound(arr)
            If InStr(arr(j, 2), col(i)) > 0 Then
                x = Round(1 / (UBound(Split(arr(j, 2), ",")) + 1), 2)
                If arr3(i, 2) = Empty Then arr3(i, 2) = x Else arr3(i, 2) = arr3(i, 2) & "+" & x
                arr3(i, 3) = arr3(i, 3) + x
            End If
        Next j
    Next i
    Range("D11").Resize(UBound(arr3), 3) = arr3
End Sub

=ЕСЛИОШИБКА(ИНДЕКС(Лист2!$C$1:$C$7;АГРЕГАТ(15;6;СТРОКА(Лист2!$C$1:$C$7)/(Лист2!$B$1:$B$7=СТОЛБЕЦ()-1);СТРОКА()-1));"")