Sub updatespravki()
UserForm1.Show
End Sub
Sub КратностьУжеНеРаботает()
Dim sh As Worksheet 'Переменная листов
Dim ВыбираюГод As Variant
                '  0          1           2            3          4           5            6           7           8            9           10
    Год = Array("2014 год", "2015 год", "2016 год", "2017 год", "2018 год", "2019 год", "2020 год", "2021 год", "2022 год", "2023 год", "2024 год")
                 '   0          1         2        3       4       5      6        7           8          9         10         11
    Месяц = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
   
For Each sh In ActiveWorkbook.Worksheets 'Перебираем листы текущей книги
 If sh.Visible = xlSheetVisible Then
 'sh.Activate
    For j = 5 To 5 'Выбери год который ты хочешь расчитать от 0 (2014 год) до 9 (2024 год)
      For k = 8 To 11 'Выбери месяц который ты хочешь расчитать от 0 (Января) до 11 (Декабря)
        ВыбранныйГод = Год(j)
        ВыбранныйМесяц = Месяц(k)
           СтрокаГода = Application.Match(ВыбранныйГод, Range("A:A"), 0) 'Определяем строку с нужным годом
           СтрокаМесяца = Application.Match(ВыбранныйМесяц, Range("A" & СтрокаГода & ":A200000"), 0) + СтрокаГода - 1 'определяем нужную нам строку с месяцем
             kratnost = 0 'Обнуляем переменную кратности
             dz = Cells(СтрокаМесяца, 7) 'Переменная Дз равна 7 столбцу в строке месяца
              For i = СтрокаМесяца To 14 Step -1 'Идем вверх начиная от строки месяца до начала (предполагается что начало будет на 14 строке)
                 'Костыль для строк с годами (с заливками)
                 For p = 0 To 10
                   If Cells(i, 1) = Год(p) Then i = i - 2 'Если значение в первом столбце равно году (из массива ГОД) тогда минус две строки
                 Next p
                   
                  '==========Работа с отрицательной кратностью==================================================================================
                   'В случае если ДЗ отрицательная...
                   If dz < 0 Then
                      If dz / Abs(Cells(i, 4)) > -1 Then 'если дз / начисления больше -1 значит дз делим на начисление
                         kratnost = kratnost + dz / Cells(i, 4)
                         dz = 0
                      Else
                         dz = dz + Cells(i, 4) 'прибавляем начисление к нашей отрицательно ДЗ
                         kratnost = kratnost - 1 'Увеличиваем кратность на 1
                      End If
                      
                      If dz = 0 Then
                         'Заполняем кратность в нужную ячейку
                         Cells(СтрокаМесяца, 9).Value = kratnost
                         GoTo endsub
                      End If
                   End If
                '==========Работа с отрицательной кратностью==================================================================================
                
                
                  If dz >= 0 Then
                  'Если начисления больше нуля
                   If Cells(i, 4) > 0 Then
                     ' Делим Дз на начисления, если они больше 1 тогда кратность увеличим
                      If dz / Abs(Cells(i, 4)) < 1 Then
                          kratnost = kratnost + dz / Cells(i, 4)
                          dz = 0
                      Else
                          dz = dz - Cells(i, 4)
                          kratnost = kratnost + 1
                      End If
                      If dz = 0 Then
                         'Заполняем кратность в нужную ячейку
                         If kratnost < 0 Then kratnost = 0
                         Cells(СтрокаМесяца, 9).Value = kratnost
                         GoTo endsub
                      End If
                  End If
                 End If
              Next
endsub:
          Next

      Next
 End If
Next
    
End Sub

={ИНДЕКС(C$5:$C$10000;ПОИСКПОЗ(0;СЧЁТЕСЛИ(C$30:C30;$C$5:$C$10000);0));0)}

=СУММПРОИЗВ(('[10.xlsx]РЕЕСТР'!$E$6:$E$120000=$C5&"*")*1;'[10.xlsx]РЕЕСТР'!$I$6:$I$120000)

=СУММПРОИЗВ(('[10.xlsx]РЕЕСТР'!$E$6:$E$120000="90*")*1;'[10.xlsx]РЕЕСТР'!$I$6:$I$120000)

For Each sh In ActiveWorkbook.Worksheets 
next

Год = Array("2018 год", "2019 год", "2020 год", "2021 год", "2022 год", "2023 год", "2024 год", "2025 год", "2026 год", "2027 год")

'Этот макрос для копирования данных. (на самом деле он тупо копирует строки которые являются голубыми или не такими как все)
Option Explicit

Sub InsRow()
'объявляем непонятные переменные
    Dim lrow&, numgr$, i&, clarr$(), rowarr$(), arr(), arr1
    Dim objDic As Object, ikey, j&
    Dim m As String
    Dim k As Variant
    'создаем директорию
    Set objDic = CreateObject("scripting.dictionary")
    'макрос работает с двумя листами shtout и shtin (наверное по этой причине они так и переименнованы в данной книге) P.S. возможно они могут работать если в With прописать "Лист 1" и _
    "Лист 2" соответственно, но это не точно.
    With Лист1
    'первый лист предполагает наличие 2р
        lrow = .Range("a" & .Rows.Count).End(xlUp).Row
        For i = 1 To lrow
            Debug.Print
            'Что-то типа если текущая ячейка удовлетворяет условию "1.* (и все что после)" тогда это номер группы
            If .Cells(i, 1).Value Like "1.*" Then numgr = .Cells(i, 1).Value
            'если мы нашли ячейку с голубым не таким как все цветом, и данная ячейка не равна группвой, тогда что-то типа мы записываем ее в объект группы
            If .Range("a" & i).Font.Color <> 0 And .Range("a" & i).Value <> numgr Then
            '.Cells(i, 1 можно поменять столбец с которого будет копироваться информация)
                objDic.Item(numgr) = objDic.Item(numgr) & .Cells(i, 1) & "||" & .Cells(i, 3) & "|||" & .Cells(i, 33) & "^"
            End If
        Next i
    End With
    'это второй лист, который является нашим основным
    With Лист2
    ' тут мы указываем какой диапазон, или грубо говоря номер последней рабочей ячейки в столбце
        lrow = .Range("a" & .Rows.Count).End(xlUp).Row
        'мы идем в обратном направлении
        For i = lrow To 1 Step -1
        'тут меняя цифру можно указать какой столбец мы используем для поиска группы
            numgr = .Cells(i, 1)
            
            If objDic.exists(numgr) Then
            
                clarr = Split(objDic.Item(numgr), "^")
                ReDim arr(1 To UBound(clarr), 2)
                j = 1
                For Each ikey In clarr
                    If ikey <> "" Then
                        arr(j, 0) = Split(ikey, "||", 2)(0)
                        arr(j, 1) = Split(Split(ikey, "||", 2)(1), "|||", 2)(0)
                        arr(j, 2) = Split(ikey, "|||", 2)(1)
                        j = j + 1
                    End If
                Next ikey
                'Вставляем строку после нужной   нам группы
                .Rows(i + 1).Resize(UBound(clarr)).Rows.Insert
                '.Cells(i + 1, 1 - меняя это число выбираем столбец куда вставлять)
                'Вставляем значения по первому листу
                For k = 1 To UBound(clarr)
                .Cells(i + k, 1) = arr(k, 0)
                .Cells(i + k, 2) = arr(k, 1)
                .Cells(i + k, 7) = arr(k, 2)
                .Cells(i + k, 13) = arr(k, 2)
                Next k
                'Вставляем значения по второму листу
               ' .Cells(i + 1, 14) = arr(1, 2)
               ' .Cells(i + 1, 20) = arr(1, 2)                            
            End If
        Next i
    End With
    MsgBox "Готово!"
End Sub

.Cells(i + k, 13) = arr(k, 2)

Dim m as String 
m = arr(k, 2)
.Cells(i + k, 13) = m