Option Explicit
Sub DelRng()

    Dim Rng As Range
    Dim DelRng As Range
    Dim c As Range

    On Error Resume Next
    Set Rng = Application.InputBox("Выделите диапазон для очистки повторяющихся значений", "Задание диапазона", Type:=8)
    On Error GoTo 0
    
    If Rng Is Nothing Then Exit Sub
    
    For Each c In Rng
        If WorksheetFunction.CountIf(Rng, c) > 1 Then
            If DelRng Is Nothing Then Set DelRng = c Else Set DelRng = Union(DelRng, c)
        End If
    Next
    
    DelRng.Clear
    
End Sub

=D3*ВПР(C3;$B$16:$D$19;ЕСЛИ(D3<=5;2;ЕСЛИ(D3>5;3));ЛОЖЬ)

Sub ЖелтыйФИО()

    Selection.Insert
    Cells(Selection.Row, 1) = Cells(Selection.Row - 1, 1)
    Cells(Selection.Row, 1).Interior.Color = vbYellow
    
End Sub

Private Sub Количество_AfterUpdate()
    If Количество <= 0 Then
        MsgBox "Введите число больше нуля"
        Количество = ""
        Количество.SetFocus
        Exit Sub
    End If
End Sub

Sub SavePicture()

    Dim i As Integer
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    i = 4
    Do While Worksheets("Проекты").Cells(i, 1) <> ""
        Worksheets("КП").Cells(3, 2) = Worksheets("Проекты").Cells(i, 1)
        Worksheets("КП").Range("B6:E15").CopyPicture
        With Worksheets("КП").ChartObjects.Add(0, 0, Worksheets("КП").Range("B6:E15").Width, Worksheets("КП").Range("B6:E15").Height).Chart
                .ChartArea.Border.LineStyle = 0
                .Parent.Select
                .Paste
                .Export Filename:=ThisWorkbook.Path & "\" & Cells(4, 2) & ".jpeg", FilterName:="JPEG"
                .Parent.Delete
        End With
        i = i + 1
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub Оценка()

    Dim СтрокаОтчет As Long
    Dim СтрокаОценка As Long
    Dim СтолбецОтчет As Integer
    
    Dim ЛистОтчет As Worksheet
    Dim ЛистОценок As Worksheet
    
    Dim НайденаДолжность As Boolean
    Dim НайденаОценка As Boolean
    
    Set ЛистОтчет = Worksheets("ППР_КПЭ_5+")
    СтрокаОтчет = 4 'Данные в отчетном листе заполняются начиная с 4 строки
    
    'Очистка заполненных данных в листах с оценками
    For Each ЛистОценок In ThisWorkbook.Worksheets
        If ЛистОценок.Name <> "ППР_КПЭ_5+" Then
            Range(ЛистОценок.Rows("5:5"), ЛистОценок.Rows("5:5").End(xlDown)).ClearContents
        End If
    Next
    
    Do Until ЛистОтчет.Cells(СтрокаОтчет, 5) = ""
            НайденаДолжность = True
        Select Case ЛистОтчет.Cells(СтрокаОтчет, 5)
            Case "2"
                Set ЛистОценок = Worksheets("Директора ССП")
            Case "3"
                Set ЛистОценок = Worksheets("Зам Директора ССП")
            Case "2.1"
                Set ЛистОценок = Worksheets("Директора Филиалов")
            Case "3.1"
                Set ЛистОценок = Worksheets("Зам Директора Филиала")
            Case Else
                НайденаДолжность = False
            End Select
            If НайденаДолжность = True Then
                    НайденаОценка = True
                Select Case ЛистОтчет.Cells(СтрокаОтчет, 9)
                    Case "B", "В"
                        СтолбецОтчет = 1
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("A:A")) + 3
                    Case "C", "С"
                        СтолбецОтчет = 6
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("F:F")) + 3
                    Case "A", "А"
                        СтолбецОтчет = 11
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("K:K")) + 3
                    Case "D"
                        СтолбецОтчет = 16
                        СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("K:K")) + 3
                    Case Else
                        НайденаОценка = False
                End Select
                    If НайденаОценка = True Then
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет) = ЛистОтчет.Cells(СтрокаОтчет, 2)
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет + 1) = ЛистОтчет.Cells(СтрокаОтчет, 3)
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет + 2) = ЛистОтчет.Cells(СтрокаОтчет, 4)
                        ЛистОценок.Cells(СтрокаОценка, СтолбецОтчет + 3) = ЛистОтчет.Cells(СтрокаОтчет, 9)
                        If ЛистОтчет.Cells(СтрокаОтчет, 8) > 1.1 Then
                            СтрокаОценка = Application.WorksheetFunction.CountA(ЛистОценок.Range("U:U")) + 3
                            ЛистОценок.Cells(СтрокаОценка, 21) = ЛистОтчет.Cells(СтрокаОтчет, 2)
                            ЛистОценок.Cells(СтрокаОценка, 22) = ЛистОтчет.Cells(СтрокаОтчет, 3)
                            ЛистОценок.Cells(СтрокаОценка, 23) = ЛистОтчет.Cells(СтрокаОтчет, 4)
                            ЛистОценок.Cells(СтрокаОценка, 24) = ЛистОтчет.Cells(СтрокаОтчет, 9)
                        End If
                    End If
            End If
        СтрокаОтчет = СтрокаОтчет + 1
    Loop
    
End Sub

Sub Отчет()

    Dim ПоследняяСтрокаОбщий As Long
    Dim ПоследняяСтрокаОтчет As Long
    Dim ПоследнийСтолбец As Long
    Dim СтрокаОбщий As Long
    Dim СтрокаОтчет As Long
    Dim Столбец As Long
    
    Dim ПутьКФайлу As String
    Dim НазваниеФайла As String
    
    Dim ОбщийФайл As Worksheet
    Dim Отчет As Worksheet
    
    Set ОбщийФайл = ThisWorkbook.Worksheets(1)
    ПутьКФайлу = ThisWorkbook.Path & "\"
    
    ПоследнийСтолбец = ОбщийФайл.Cells.SpecialCells(xlLastCell).Column
    ПоследняяСтрокаОбщий = ОбщийФайл.Cells.SpecialCells(xlLastCell).Row
    
    For Столбец = 3 To ПоследнийСтолбец
        'Название файла формируюется из месяца и года в заголовках начиная с третьего столбца. Все названия отчетных файло должны быть вид "ммгггг"
        'Все отчетные файлы находятся в той же папке, что и общий файл
        НазваниеФайла = Format(DatePart("m", Cells(1, Столбец)), "00") & DatePart("yyyy", Cells(1, Столбец))
        НазваниеФайла = ПутьКФайлу & НазваниеФайла
        If Dir(НазваниеФайла & "*") <> "" Then
            НазваниеФайла = Dir(НазваниеФайла & "*")
            Set Отчет = Workbooks.Open(ПутьКФайлу & НазваниеФайла).Worksheets(1)
            ПоследняяСтрокаОтчет = Отчет.Cells.SpecialCells(xlLastCell).Row
            СтрокаОбщий = 2
            Do While СтрокаОбщий <> ПоследняяСтрокаОбщий + 1
                СтрокаОтчет = 2
                Do While СтрокаОтчет <> ПоследняяСтрокаОтчет + 1
                    'Наименование в общем и отчетном файлах начинается со второй строки первого столбца
                    If Отчет.Cells(СтрокаОтчет, 1) = ОбщийФайл.Cells(СтрокаОбщий, 1) Then
                        'Суммы в отчетных файлах находятся в третьем столбце
                        ОбщийФайл.Cells(СтрокаОбщий, Столбец) = Отчет.Cells(СтрокаОтчет, 3)
                        СтрокаОтчет = СтрокаОтчет + 1
                        Exit Do
                    End If
                    СтрокаОтчет = СтрокаОтчет + 1
                Loop
                СтрокаОбщий = СтрокаОбщий + 1
            Loop
            ActiveWorkbook.Close (False)
        End If
    Next

End Sub

Sub Заполнить()
    Dim Строка As Long
    If Selection = "" Then Exit Sub
    Строка = Cells.SpecialCells(xlCellTypeLastCell).Row
    Selection.AutoFill Destination:=Range("A" & Selection.Row & ":A" & Строка), Type:=xlFillCopy
End Sub

=ЕСЛИ(СЧЁТЕСЛИ(A$2:A3;A3)=6;A3+1;A3)

=0,5*СУММ('Отчетп о сделкам'!$B:$B)

=0,3*СУММ('Отчетп о сделкам'!$B:$B)

=СУММЕСЛИ(Лист2!A:A;Лист1!A4&"*";Лист2!B:B)

Sub Формат()

    Dim Строка As Long
    Dim ПоследняяСтрока As Long
    
    ПоследняяСтрока = Cells.SpecialCells(xlCellTypeLastCell).Row
    Строка = 1
    For Строка = 1 To ПоследняяСтрока
        If Cells(Строка, 2) <> "" Then
            If Cells(Строка, 2) Like "Карта*" Then
                Cells(Строка + 1, 1).FormulaR1C1 = "=SUBSTITUTE(MID(R[-1]C[1],8,22),"" "","""")"
                Cells(Строка + 1, 1) = Cells(Строка + 1, 1)
            Else
                If Cells(Строка + 1, 2) <> "" Then Cells(Строка + 1, 1) = Cells(Строка, 1)
            End If
        End If
    Next

End Sub

Worksheets("Лист3").Range("A2:D5").FormulaArray = "=Лист1!RC:R[3]C[3]-Лист2!RC:R[3]C[3]"