Sub aimv()
Dim ws As Worksheet
Dim wb As Workbook
Dim r As Range
Dim cc As Long, cr As Long
Dim i, x
Set wb = ActiveWorkbook
Application.ScreenUpdating = False
    cc = Cells(2, Columns.Count).End(xlToLeft).Column
    cr = Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To cc
            If Cells(2, i).MergeCells = True Then
                x = Cells(2, i).MergeArea.Columns.Count
                Set r = Range(Cells(2, i), Cells(cr, x + 2 + i))
                Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
                ws.Name = Sheets("Лист1").Cells(2, i).Value
                r.Copy Worksheets(ws.Name).Range("A1")
                Sheets("Лист1").Select
                i = i + x + 2
            End If
        Next i
For i = 2 To Sheets.Count
        x = Sheets(i).Name
        Sheets(i).Copy
        ActiveWorkbook.SaveAs wb.Path & "\" & x & ".xlsx"
        ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
End Sub

Sub Перенести()
    Dim shSrc As Worksheet, arrSrc(), arrIsp(), shRes As Worksheet
    Dim lr As Long, r As Long, i As Long
    Application.ScreenUpdating = False
    Set shSrc = Worksheets("2017")
    Set shRes = Worksheets("Просрочка по контрактам")
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    shRes.Rows("1:" & lr).Delete
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    arrSrc() = shSrc.Range("T1:T" & lr).Value
    arrIsp() = shSrc.Range("Y1:Y" & lr).Value
    shSrc.Rows(1).Copy shRes.Cells(1, "A")
    r = 1
    For i = 2 To UBound(arrSrc)
        If arrSrc(i, 1) <> "" Then
            If arrSrc(i, 1) <= Date And arrIsp(i, 1) <> "ИСПОЛНЕН" Then
                r = r + 1
                shSrc.Rows(i).Copy shRes.Cells(r, "A")
            End If
        End If
    Next i
    shRes.Select
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value < 0 Then Target.Value = 0
End Sub

Sub Reestr()
Dim ar()
iclr = ActiveWorkbook.Sheets("Реестр").Cells(Rows.Count, 2).End(xlUp).Row
ar = ActiveWorkbook.Sheets("Лист1").Range("B1:B7").Value
ActiveWorkbook.Sheets("Реестр").Cells(iclr + 1, 1).Resize(, 7).Value = Application.Transpose(ar())
End Sub

Sub kaktuz()
Dim iclr As Long
Dim i As Long
iclr = Cells(Rows.Count, 2).End(xlUp).Row
    For i = iclr To 2 Step -1
        Rows(i).Select
        ActiveCell.Resize(4).EntireRow.Insert
        Range(Cells(i, 2), Cells(i + 4, 2)).Merge
        Cells(i, 3).Resize(5, 1).Value = Application.Transpose(Array("элемент-1", "элемент-2", "элемент-3", "элемент-4", "элемент-5"))
    Next i
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Set Rng = Columns(1).Find(what:="OK", LookIn:=xlValues, lookAt:=xlWhole)
        If (Target.Column = 1) Then
            If IsEmpty(Target) = True Then
                ActiveSheet.Unprotect
            Exit Sub
            End If
        If Not Rng Is Nothing Then
            ActiveSheet.Unprotect
            With ActiveSheet
                .Range("B:Z").Locked = True
                .Protect
            End With
        Else
            ActiveSheet.Unprotect
        End If
    End If
End Sub

Sub Resultat()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim Kod1 As Integer
Dim Kod2
Dim iGruppa As String
  iLastRow = [B2].End(xlDown).Row
     For i = iLastRow To 3 Step -1
       If InStr(1, Cells(i, 4), " ") <> 0 Then
         Kod1 = Cells(i, 2)
         Kod2 = Split(Cells(i, 4), " ")
         iGruppa = Cells(i, 3)
         Set rng = Range(Cells(i, 5), Cells(i, 8)) 'добавил
         For j = 0 To UBound(Kod2)
           Rows(i + j).Insert
           Cells(i + j, 2) = Kod1
           Cells(i + j, 4) = Kod2(j)
           Cells(i + j, 3) = iGruppa
           Range(Cells(i + j, 5), Cells(i + j, 8)).Value = rng.Value 'добавил
         Next
           Rows(i + j).Delete
       End If
     Next i
End Sub

cmt.Text Text:=Format(Now, strDate) & Chr(10) & cmt.Text '& Chr(10) - новая строка

Sub www()
Dim i As Long
Dim y As Long
    For i = 12 To Range("a1").SpecialCells(xlLastCell).Row
        If InStr(Cells(i, 1), "Дата") > 0 Then
            For y = i + 1 To Range("a1").SpecialCells(xlLastCell).Row
                If InStr(Cells(y, 1), "Итого по абоненту") > 0 Then
                    Cells(y, 21).Value = Application.Sum(Range(Cells(i + 1, 21), Cells(y - 1, 21)))
                    i = y
                    Exit For
                End If
            Next y
        End If
    Next i
End Sub