Dim ShData As Worksheet
Dim ListObj As ListObject
Dim ListR As ListRow
Dim a As Variant
Dim i As Byte

Set ShData = ThisWorkbook.Worksheets("data")
Set ListObj = ShData.ListObjects("работник_тб")
Set ListR = ListObj.ListRows(1)

    If cbx_exclude.Value = True Then
        cmb_rabotnik.RowSource = ""
        With CreateObject("scripting.dictionary")
            For Each ListR In ListObj.ListRows
'                Debug.Print uf_inputData.lbx_rabotniki.List(i, 0)
'                Debug.Print ListR.Range(1).Value
                For i = 0 To uf_inputData.lbx_rabotniki.ListCount
                    If ListR.Range(1).Value = uf_inputData.lbx_rabotniki.List(i, 0).Value Then
                        .Item(ListR.Range(1).Value) = vbNullString
                    End If
                Next i
            Next
            a = .keys
        End With
        uf_inputData.cmb_rabotnik.List = Application.Transpose(a)
    Else
        cmb_rabotnik.RowSource = "работник_тб"
    End If

Sub EditNextYear(ByRef yeargraf As Integer, wbName As String)

Dim DatListObj As ListObject
Dim DatListRow As ListRow

    With Workbooks(wbName).Sheets("график ТО")
        .Activate
'    редактирование нового графика ТО
        .Range("grafik_TO_tb[дата ТО/ диагн.]").ClearContents
        .Range("grafik_TO_tb[№ акта ТО]").ClearContents
        .Range("grafik_TO_tb[дата согласов.]").ClearContents
        .Range("grafik_TO_tb[организация проводившая ТО]").ClearContents
        .Range("grafik_TO_tb[дата след. ТО]").Cut Range("grafik_TO_tb[дата ТО/ диагн.]")
    End With
    
Set DatListObj = Workbooks(wbName).Worksheets("график ТО").ListObjects("grafik_TO_tb")
Set DatListRow = DatListObj.ListRows(1)

    yeargraf = Year(DatListRow.Range(13))
    
    For Each DatListRow In DatListObj.ListRows
        If DatListRow.Range(17).Value <> "" Then
            DatListRow.Range(12).Value = DatListRow.Range(17).Value
            DatListRow.Range(17).Value = ""
        End If
        If DatListRow.Range(25).Value <> "" And Year(DatListRow.Range(25)) = yeargraf - 1 Then
            DatListRow.Range(12).Value = DatListRow.Range(25).Value
        End If
        If DatListRow.Range(27).Value <> "запрет" Then
            If Year(DatListRow.Range(27)) = yeargraf Or Year(DatListRow.Range(27)) < yeargraf Then
                DatListRow.Range(31).Value = "диагностика"
            Else
                DatListRow.Range(31).Value = "т/о"
            End If
        End If
    Next DatListRow
    
    Workbooks(wbName).Sheets("график ТО").Range("grafik_TO_tb[дата ТО/ диагн.]").NumberFormat = "mmm/yyyy"

End Sub

Sub EditNextYear(ByRef yeargraf As Integer, wbName As String)

Dim DatListObj As ListObject
Dim DatListRow As ListRow

    With Workbooks(wbName).Sheets("график ТО")
        .Activate
'    редактирование нового графика ТО
        .Range("grafik_TO_tb[дата ТО/ диагн.]").ClearContents
        .Range("grafik_TO_tb[№ акта ТО]").ClearContents
        .Range("grafik_TO_tb[дата согласов.]").ClearContents
        .Range("grafik_TO_tb[организация проводившая ТО]").ClearContents
        .Range("grafik_TO_tb[дата след. ТО]").Cut Range("grafik_TO_tb[дата ТО/ диагн.]")
    End With
    
Set DatListObj = Workbooks(wbName).Worksheets("график ТО").ListObjects("grafik_TO_tb")
Set DatListRow = DatListObj.ListRows(1)

    yeargraf = Year(DatListRow.Range(13))
    
    For Each DatListRow In DatListObj.ListRows
        If DatListRow.Range(17).Value <> "" Then
            DatListRow.Range(12).Value = DatListRow.Range(17).Value
            DatListRow.Range(17).Value = ""
        End If
        If DatListRow.Range(25).Value <> "" And Year(DatListRow.Range(25)) = yeargraf - 1 Then
            DatListRow.Range(12).Value = DatListRow.Range(25).Value
        End If
        If DatListRow.Range(27).Value <> "запрет" Then
            If Year(DatListRow.Range(27)) = yeargraf Or Year(DatListRow.Range(27)) < yeargraf Then
                DatListRow.Range(31).Value = "диагностика"
            Else
                DatListRow.Range(31).Value = "т/о"
            End If
        End If
    Next DatListRow
    
    Workbooks(wbName).Sheets("график ТО").Range("grafik_TO_tb[дата ТО/ диагн.]").NumberFormat = "mmm/yyyy"

End Sub

Sub ПроверкаЖурналаЗаявок()

    Dim rngX As Range
    Dim c As Range
    Dim i As Integer
    Dim iM As Integer
    Dim iP As Integer
    Dim colF As Double

    
Set rngX = Selection
Set c = rngX.Cells

    i = 0
    iM = 0
    iP = 0
    
    For Each c In rngX
        If c.Value <> "" Then
            i = i + 1
            colF = c.Font.Color
            If colF = 1842204 Or colF = 1118481 Or colF = 0 Then
                iM = iM + 1
            End If
            If colF = 255 Or colF = 204 Then
                iP = iP + 1
            End If
        End If
    Next c
    
    Debug.Print "всего "; i
    Debug.Print "выход мех."; iM
    Debug.Print "простоев"; iP
    
    i = i - iM - iP
    
    Debug.Print "аварийка"; i

End Sub

Sub FillYear()

    Dim coll
    Dim i As Byte
    Dim PathDir As String
    
    PathDir = ThisWorkbook.Path & "\"

    Set coll = SubFoldersCollection(PathDir, "20##")
 
    For i = 1 To coll.Count
'        Debug.Print coll(i)
        Form_Selection.cmb_year.AddItem coll(i)
    Next i

End Sub


Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$) As Collection

    Dim FSO As Object
    Dim curfold As Object
    Dim folder As Object

    Set SubFoldersCollection = New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")

    
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$)
    
    For Each folder In curfold.SubFolders
        If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add Right(folder.Path, 4)
    Next folder
    
    Set FSO = Nothing
    
End Function

cells(1, 1).Select

Sub CopyDataJournal()

Dim lRow As Long
Dim ishodnik As Workbook

Set ishodnik = Workbooks("Журнал заявок  2016 г..xls")
    
    ishodnik.Sheets(1).Columns(5).EntireColumn.Hidden = False
    ishodnik.Sheets(1).Columns("J:L").EntireColumn.Hidden = False
    lRow = ishodnik.Sheets(1).Cells(Rows.Count, 16).End(xlUp).Row

    ishodnik.Sheets(1).Range(Cells(2, 1), Cells(lRow, 16)).Copy
    lRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
    ThisWorkbook.Sheets(1).Range(Cells(lRow, 1)).PasteSpecial Paste:=xlPasteValues

End Sub

Private Sub CheckBox1_Click()

    If Cells(11, 1) <> "" Then
        If General.CheckBox1.Value = True Then
            With General.cmb_street
                .Locked = True
                .BackColor = RGB(240, 240, 240)
            End With
        Else
            With General.cmb_street
                .Locked = False
                .BackColor = ColorConstants.vbWhite
            End With
        End If
    Else
        General.CheckBox1.Value = False
        MsgBox "Невозможно." & vbCr & "Таблица не заполнена", vbCritical, "Ошибка!"
    End If

End Sub

Private Sub cmb_street_Change()
    
    Dim DatListObj As ListObject
    Dim DatListRow As ListRow
    
Set DatListObj = ThisWorkbook.Worksheets("данные").ListObjects("mehanic_tb")
Set DatListRow = DatListObj.ListRows(1)
    
    For Each DatListRow In DatListObj.ListRows
        If DatListRow.Range(1) = cmb_street Then
            General.cmb_house.AddItem DatListRow.Range(2)
        End If
    Next DatListRow
    
End Sub

    Dim DatListObj As ListObject
    Dim DatListRow As ListRow
    Dim adres As String

Set DatListObj = ThisWorkbook.Worksheets("data").ListObjects("mehanic_tb") 
Set DatListRow = DatListObj.ListRows(1)

    adres = cmb_street & txb_house & txb_lift
    
    For Each DatListRow In DatListObj.ListRows
        If DatListRow.Range(1) & DatListRow.Range(2) & DatListRow.Range(3) = adres Then
            Exit For
        End If
    Next DatListRow

   If DatListRow = Nothing Then        MsgBox "нет такого!"
        GoTo ending
    End If

   Dim nRow As Integer
   nRow = Range("grafik_PPR_tb").Rows.Count

Rows(6:nrow+5).Delete Shift:=xlUp

   Dim nRow As Integer
    nRow = Range("grafik_PPR_tb").Rows.Count
    
    For i = nRow To 6 Step -1
        If i > 6 Then
            Rows(i).Delete
        End If
    Next i

Range("A1:A6").Cut
Range("D1").Select
ActiveSheet.Paste

ActiveSheet.ListObjects("grafik_TO_tb").Range.AutoFilter Field:=8, Operator:=xlFilterValues, Criteria2:=Array(1, "2/2/2016")