Sub stolbec()
Const List1 = "K1"
Const List2 = "H bb"
Dim ww As Integer
Dim wwCTOL As Integer


Application.ScreenUpdating = False
Sheets(List1).Activate

Range("a1").Select

wwCTOL =  0 
ww =  0 

        Do Until ww = ActiveSheet.UsedRange.Columns.Count
            If ActiveCell.Value = "Месяц" Or ActiveCell.Value = "Работник1" _
            Or ActiveCell.Value = "Работник1" Or ActiveCell.Value = "xp" Then

                Selection.EntireColumn.Copy
                Sheets(List2).Activate

                 ActiveSheet.PasteSpecial xlValues  '******** здесь выдаёт ошибку

                ActiveCell.Offset( 0 ,  1 ).Select
                Sheets(List1).Select
                 ActiveCell.Offset( 0 ,  1 ).Select
                 wwCTOL = wwCTOL +  1 
                 Else
                 ActiveCell.Offset( 0 ,  1 ).Select
            End If
        ww = ww +  1 
        Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "bylo skopirowano " & wwCTOL & "  stolbcow"

End Sub

Range("a:a").Select
Selection.Delete

Set rng = xlSh1.Range("1:1").Find(mList(i), xlSh1.Range("A1"), LookIn:=xlFormulas, LookAt:= _
          xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
      ....
         xlSh2.Cells( 1 , xlSh2.Cells( 1 , Columns.Count).End(xlToLeft).Column +  1 ).PasteSpecial xlValues

    mList( 0 ) = "Месяц"
    mList( 1 ) = "Работник1"
    mList( 2 ) = "Работник2"
    mList( 3 ) = "Авто"
    mList( 4 ) = "xp"

Dim mList( 20 ) As String

xlSh2.Cells( 1 , Columns.Count).End(xlToLeft).Column

xlSh2.Range("B:L").Select
    Selection.Clear

xlSh2.Range("B:L").Clear

Set xlSh2 = Worksheets(List2)

Sub del2()

Dim r As Range
Dim n As Integer
Dim gh As Long
Sheets("H bb").Activate
Application.ScreenUpdating = False
gh = ActiveSheet.UsedRange.Rows.Count '*****
                                
Set r = Range("a2:k2")

For n =  1  To gh          '****
    If r.Cells(n,  6 ).Value = r.Cells(n,  7 ).Value = r.Cells(n,  8 ).Value = r.Cells(n,  9 ).Value Then
    Cells(n,  6 ).Offset( 1 ,  0 ).Interior.ColorIndex =  37 
'
'
'    If Cells(n, 6).Offset(1, 0).Interior.ColorIndex = 37 Then
     Cells(n,  6 ).Offset( 1 ,  0 ).EntireRow.Delete
        
'    Exit For

    'End If
    'Else
    
    End If
'    n = n + 1
Next n

End Sub

Sub del2()..

For n =  1  To gh         
    If r.Cells(n,  6 ).Value = r.Cells(n,  7 ).Value = r.Cells(n,  8 ).Value = r.Cells(n,  9 ).Value Then
    'Cells(n, 6).Offset(1, 0).Interior.ColorIndex = 37
    Cells(n,  6 ).Offset( 1 ,  0 ).EntireRow.Delete
    
    Else            '********!
    ActiveCell.Offset( 1 ,  0 ).Select  '********!
  
End If
Next n

  ....
  Set xlSh = Sheets("H bb")

    For n =  2  To xlSh.UsedRange.Rows.Count
     If xlSh.Cells(n,  6 ).Value = xlSh.Cells(n,  7 ).Value = xlSh.Cells(n,  8 ).Value = _
            xlSh.Cells(n,  9 ).Value Then
    
'        If xlSh.Cells(n, 6).Text = "0" And _
'            xlSh.Cells(n, 7).Text = "0" And _
'            xlSh.Cells(n, 8).Text = "0" And _
'            xlSh.Cells(n, 9).Text = "0" Then
'
            '**************
            If rng Is Nothing Then
            Set rng = xlSh.Cells(n,  6 )
....

  ...   If xlSh.Cells(dr,  6 ).Value = xlSh.Cells(dr,  7 ).Value = xlSh.Cells(dr,  8 ).Value = _
            xlSh.Cells(dr,  9 ).Value Or xlSh.Cells(dr,  3 ).Text = "C101*" Then
    
          '   If xlSh.Cells(dr, 3).Value = "C101*" Then '**
            If pnk Is Nothing Then
                Set pnk = xlSh.Cells(dr,  6 )
            Else
                Set pnk = Union(pnk, xlSh.Cells(dr,  6 ))
            End If
        End If
        'End If ...'**

 xlSh.Cells(dr,  3 ).Text Like "C101*" 

Mid(xlSh.Cells(dr,  3 ).Text,  1 ,  3 ) = "C101"

....
    If Not pnk Is Nothing Then pnk.EntireRow.Delete
    
            'Sub del_C()
        
        Dim ctr As Range
        Dim cti As Integer
        Set ctr = Range("a1:k1")
        Set xlSh = Sheets("H bb")
        For cti =  1  To xlSh.UsedRange.Rows.Count
            If ctr.Cells(cti,  3 ).Text Like "*C101*" Then
            ctr.Cells(cti,  3 ).EntireRow.Delete
            End If
        Next cti
        Application.ScreenUpdating = True
            'End Sub
....

    ....Dim xlSh As Worksheet
      Application.ScreenUpdating = False
....
            Else
                Set pnk = Union(pnk, xlSh.Cells(dr,  6 ))
            End If
        End If
        'End If '**
       ' if pnk.Cells(dr,3).Value="C101"
    Next
    If Not pnk Is Nothing Then pnk.EntireRow.Delete
    
            'Sub del_C()
        
        Dim ctr As Range
        Dim cti As Integer
        Set ctr = Range("a1:k1")
        Set xlSh = Sheets("H bb")
        For cti =  1  To xlSh.UsedRange.Rows.Count
            If ctr.Cells(cti,  3 ).Text Like "*C101*" Then
            ctr.Cells(cti,  3 ).EntireRow.Delete
            End If
        Next cti
        Application.ScreenUpdating = True
        
        'End Sub
End Sub

Delete

ClearContents

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