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