Range(Cells( 2 , 1 ), Cells(ActiveSheet.UsedRange.Rows.Count, 1 )) = "Сентябрь"

.....

    For n =  2  To xlSh.UsedRange.Rows.Count              '***Cells(Rows.Count, 6).End(xlUp).Row
        fl = False
        If xlSh.Cells(n,  6 ) =  0  And xlSh.Cells(n,  7 ) =  0  And _
            xlSh.Cells(n,  8 ) =  0  And xlSh.Cells(n,  9 ) =  0  Then
            fl = True
        ElseIf xlSh.Cells(n,  3 ).Text Like "*C101*" Then
            fl = True
        End If
     
        If fl Then
            If rng Is Nothing Then
                Set rng = xlSh.Cells(n,  6 )
            Else
                Set rng = Union(rng, xlSh.Cells(n,  6 ))
            End If
        End If
    Next
    If Not rng Is Nothing Then rng.EntireRow.ClearContents  '*****
       '**********
         If xlSh.Cells(n,  6 ).Value = "" And xlSh.Cells(n,  7 ).Value = "" And _
            xlSh.Cells(n,  8 ).Value = "" And xlSh.Cells(n,  9 ).Value = "" Then
            xlSh.Cells(n,  6 ).EntireRow.ClearContents '******
        End If
            '*********
'        Sub CopT_()
    Columns("C:C").Select
    Range("A1:j7000").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:= 1 , MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("A1").Select
            'End Sub
                '**********
    Range(Cells( 2 ,  1 ), Cells(ActiveSheet.UsedRange.Rows.Count,  1 )) = "Сентябрь"
   ' Sub Kriter_()
    Range("A1").Select
    Selection.AutoFilter Field:= 6 , Criteria1:=">0", Operator:=xlAnd
    Selection.AutoFilter Field:= 7 , Criteria1:=">0", Operator:=xlAnd
    Selection.AutoFilter Field:= 8 , Criteria1:=">0", Operator:=xlAnd
    Selection.AutoFilter Field:= 9 , Criteria1:=">0", Operator:=xlAnd
    'End Sub
    
    '********

End Sub

Sub del12()
Sheets("H bb").Activate
...

Range("A1").Select

ActiveWorkbook.ActiveSheet.Range("A1").Select

     .....        DataOption1:=xlSortNormal  '*********
    Dim i as Integer '  ****
    i = xlSh.Cells(Rows.Count,  6 ).End(xlUp).Row
    xlSh.Range(Cells( 2 ,  1 ), Cells(i,  1 )) = "Сентябрь"
    With xlSh.Range("A1") '******
        ....
    
'**************

Sub M_Hbb()
   Sheets("H bb").Activate
     
         '**********
    'Sub VKL()
 
     Rows("1:1").Select
     On Error Resume Next
    Selection.AutoFilter

    '************
        
    Const List1 = "K1"
    Const List2 = "H bb"
    Dim i As Integer
    Dim mList( 18 ) As String
    Dim xlSh1 As Worksheet, xlSh2 As Worksheet, rng As Range
    '   

    mList( 0 ) = "Участок*"
    mList( 1 ) = "Работник*"
    mList( 2 ) = "TC*"
    
    Range("a:L").Clear
    Range("A1").Select
    Application.ScreenUpdating = False

    Set xlSh1 = Worksheets(List1)
    Set xlSh2 = Worksheets(List2)
       '********
    For i =  0  To UBound(mList)
        Set rng = xlSh1.Range("1:1").Find(mList(i), xlSh1.Range("A1"), LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
        If Not rng Is Nothing Then
            rng.EntireColumn.Copy
            xlSh2.Cells( 1 , xlSh2.Cells( 1 , Columns.Count).End(xlToLeft).Column +  1 ).PasteSpecial xlValues
        Else
       MsgBox "не найден параметер:" & mList(i)
            
        End If
        
    Next
    
    Application.CutCopyMode = False
  
    '********
'    Cells.Columns.AutoFit
    Columns("F:I").NumberFormat = "m/d/yyyy"
    'Range("A1").Select
 '**********


'Sub del22()
'**********
    Dim rngB As Range
    Dim n As Integer
    'Dim xlSh2 As Worksheet
    Dim fl As Boolean
    
    'Set xlSh2 = Sheets(List2)
'************

    For n =  2  To xlSh2.UsedRange.Rows.Count              'Cells(Rows.Count, 6).End(xlUp).Row
        fl = False
        If xlSh2.Cells(n,  6 ) =  0  And xlSh2.Cells(n,  7 ) =  0  And _
            xlSh2.Cells(n,  8 ) =  0  And xlSh2.Cells(n,  9 ) =  0  Then
            fl = True
        ElseIf xlSh2.Cells(n,  3 ).Text Like "*B*" Then
            fl = True
        End If
     
        If fl Then
            If rngB Is Nothing Then
                Set rngB = xlSh2.Cells(n,  6 )
            Else
                Set rngB = Union(rngB, xlSh2.Cells(n,  6 ))
            End If
        End If
    Next
    If Not rngB Is Nothing Then rngB.EntireRow.ClearContents  '*****
       '**********
         If xlSh2.Cells(n,  6 ).Value = "" And xlSh2.Cells(n,  7 ).Value = "" And _
            xlSh2.Cells(n,  8 ).Value = "" And xlSh2.Cells(n,  9 ).Value = "" Then
            xlSh2.Cells(n,  6 ).EntireRow.ClearContents '******
        End If
        
        '***********
          '*********
'        Sub CopT_()

        xlSh2.Range("A1:j" & xlSh2.UsedRange.Rows.Count).Sort Key1:=xlSh2.Range("C1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:= 1 , MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

             '**********
    Dim asy As Integer
    asy = xlSh2.Cells(Rows.Count,  6 ).End(xlUp).Row  '******
    xlSh2.Range(Cells( 2 ,  1 ), Cells(asy,  1 )) = "Сентябрь"   '******
 
       Range("a1") = "Месяц"
'        '********
'          If xlSh1.Cells(0, 3).Value = xlSh1.Cells(0, 4).Value = _
'       xlSh1.Cells(0, 5).Value = xlSh1.Cells(0, 6).Value = _
'       xlSh1.Cells(0, 7).Value = xlSh1.Cells(0, 8).Value Then
'      Cells.ClearContents
'      Else
'      End If
'        '*********
        '*********
          Rows("1:1").Select
    Selection.Font.Bold = True
    Range("A1").Select
'    Columns("A:A").ColumnWidth = 10
    
    '******
    '*********
'    Sub Kriter_()
  With xlSh2.Range("A1")
        .AutoFilter Field:= 6 , Criteria1:=">0", Operator:=xlAnd
        .AutoFilter Field:= 7 , Criteria1:=">0", Operator:=xlAnd
        .AutoFilter Field:= 8 , Criteria1:=">0", Operator:=xlAnd
        .AutoFilter Field:= 9 , Criteria1:=">0", Operator:=xlAnd
    End With
    'End Sub
    
    '********
'End Sub
'End If
Application.ScreenUpdating = True
     '  *******
          If xlSh1.Cells( 0 ,  3 ) =  0  And xlSh1.Cells(,  4 ) =  0  And _  ' проблемный участок
          xlSh1.Cells( 0 ,  5 ).Value = xlSh1.Cells( 0 ,  6 ).Value = _
          xlSh1.Cells( 0 ,  7 ).Value = xlSh1.Cells( 0 ,  8 ).Value Then
           Cells.Clear                 ' проблемный участок
' Exit Sub
          End If
'***************

End Sub