Sub NewMenu100()

On Error Resume Next

Application.CommandBars.Add("Отчет ТОП 100").Delete
With Application.CommandBars.Add("Отчет ТОП 100", , False, True)
    With .Controls.Add
    .Caption = "ТОП 100"
    .FaceId = 69
    .Style = 3
    .TooltipText = "Формирование отчета ТОП 100"
    .OnAction = "Start100"
    End With
.Visible = True
End With

End Sub

rs.Open "SELECT * FROM Itog WHERE " & st1 & st3 & st4 & st5 & st6 & st7 & st2 & " ORDER BY 1", cn, adOpenStatic, adLockReadOnly
   Worksheets(Jnxtn gj ghjtrnfv").Range("B6").CopyFromRecordset rs
rs.Close

'Соединение с базой и получение данных в Combobx-ы'
cn.Open    
sSQL = "Select distinct id1 From Itog Where id1 IS NOT NULL Order by 1"    
Set rs = cn.Execute(sSQL)    
If Not cn.State = 1 Then Exit Sub    
a = rs.GetRows   
 Me.ComboBox1.List = Application.Index(a, 1, 0)
rs.Close:     
cn.Close
'-------------------
cn.Open    
sSQL = "Select distinct id2 FROM Itog ORDER BY 1"    
Set rs = cn.Execute(sSQL)
    If Not cn.State = 1 Then Exit Sub
    a = rs.GetRows
    Me.ComboBox2.List = Application.Index(a, 1, 0)
rs.Close:
cn.Close

'1)время обработки данных
    T1 = Timer
    T3 = T1 - t
'    2)вывод на лист
Application.ScreenUpdating = False 'Выключаем обновление экрана'
MsgBox "Обработка данных - " & T3 & "cek"
   With Sheets("Sheet1")
'        Set Cel = .Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Cells(6, 1).Resize(K, Col).Value = Result ' Вывод данных из массива на лист
   End With
Application.ScreenUpdating = True 'Выключаем обновление экрана'
   T2 = Timer - T1
'   информация о времени работы.
   MsgBox "Вывод на лист - " & T2 & "cek" & Chr(10) , , "Проверка на скорость"

n = 1
Do While Worksheets("Лист1").Cells(n, 1) <> ""
   Worksheets("Лист1").Rows(n).Copy Worksheets("Лист2").Range("A" & n)
   'MsgBox Sheets("Лист1").Cells(n, 1).Value & " = " & Sheets("Лист2").Cells(n, 1).Value
n = n + 1
Loop

n = 1
Do While Worksheets("Лист1").Cells(n, 1) <> ""
   Worksheets("Лист1").Rows(n).Copy Worksheets("Лист2").Range("A" & n)
   'MsgBox Sheets("Лист1").Cells(n, 1).Value & " = " & Sheets("Лист2").Cells(n, 1).Value
n = n + 1
Loop

For j = 1 To 800
    For i = 1 To 4000
         If StrComp(Sheets("Город").Range("A" & j), Sheets("Улица").Range("A" & i), vbTextCompare) = 0 Then
            Sheets("Улица").Range("D" & j).Interior.Color = 0
             Exit For
        Else
            Sheets("Улица").Range("D" & j).Interior.Color = 255
        End If
    Next i
Next j

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
   Private Sub Worksheet_Activate()
       ... Код_Заливаем ячейки
   End Sub
... Код_Считаем честно залитое
End Sub

UserForm2.TextBox1 = Date
UserForm2.TextBox2 = WorksheetFunction.EoMonth(Date, 0)

Private Sub CommandButton2_Click()
'---------      Формирование результатов - послать на сервер запрос      ---------'
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim ConnectionString As String
Dim DateBeg As String, DateEnd As String, st1 As String, st2 As String, DateBeg1 As String, DateEnd1 As String

'Формируем и открываем строку подключения, подключаемся к SQL-серверу '
cn.ConnectionString = "Provider=sqloledb;Data Source=10.52.1.72;Initial Catalog=OMNI_Report;Integrated Security=SSPI;" 'Строка соединения с SQL-сервером'
cn.Open ConnectionString

DateBeg = Format$(UserForm1.TextBox1, "'YYYYMMDD'")
DateEnd = Format$(UserForm1.TextBox2, "'YYYYMMDD'")
'DateBeg1 = Format$(UserForm1.TextBox1, "'YYYYMMDD'")
'DateEnd1 = Format$(UserForm1.TextBox2, "'YYYYMMDD'")
'MsgBox TypeName(DateEnd)
MsgBox DateBeg & " - " & DateEnd, vbOKOnly, "ОП"
DateBeg1 = """" & DateBeg & """" '& " _ " & DateEnd
MsgBox DateBeg1
MsgBox TypeName(DateBeg1)


st1 = "'%" & UserForm1.ComboBox1 & "%'" ' Подготовка переменной к иcпользованию в LIKE

rs.Open "SELECT ROW_NUMBER() OVER(ORDER BY Исполнитель), " _
      & "Группа, Исполнитель, " _
      & DateBeg1 & ",SUM(затраты), " _
      & "'', '','' " _
      & "FROM Труд " _
      & "WHERE Исполнитель LIKE " & st1 & "" _
      & "AND Дата BetWeen " & DateBeg & " AND " & DateEnd & "" _
      & "GROUP BY Группа, Исполнитель " _
      & "ORDER BY 3", cn, adOpenStatic, adLockReadOnly

'----     Копирование RecordSet на РАБОЧИЙ лист    ------'
Worksheets("Лист1").Range("A5").CopyFromRecordset rs

rs.Close
cn.Close

End Sub

Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

For j = 5 To iLastRow
    For i = 1 To iLastRow1
        If Sheets("Sheet1").Range("G" & j) = Sheets("Категория КЕ").Range("A" & i) Then
            Sheets("Sheet1").Range("G" & j).Interior.ColorIndex = 0
        Else
        'MsgBox Range("G" & j)
            Sheets("Sheet1").Range("G" & j).Interior.ColorIndex = vbRed 'vbBlue
        End If
    Next i
Next j

Private st As String
SPrivate Sub CommandButton1_Click()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Worksheets("Config").Cells(3, 2) & "Project.mdb; Jet OLEDB:Database;"
'Dim st As String'
'Static st As String'
   
If ActiveControl.Name = "ComboBox1" Then
   st=ComboBox1 'Значение комбобокса в переменную'
   MsgBox st & "1"
End If

If ActiveControl.Name = "ComboBox2" Then
   msgbox st & "2"   ' при переходе в ComboBox2 - переменная st очищается, Не передается (
cn.Open ConnectionString
'значение переменной st не передается в запрос'
rs.Open "SELECT * FROM Itog WHERE Status='" & st & "' AND Kod_zak='" & ComboBox2 & "' AND Kod_zak IS NOT NULL ORDER BY 1", cn, adOpenStatic, adLockReadOnly
End If
End Sub

rs.Open "SELECT * FROM Itog WHERE CDate(BegProekt) >" & DateBeg & " ORDER BY 1", cn, adOpenDynamic, adLockBatchOptimistic

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

Dim DateBeg As String

DateBeg = UserForm.TextBox1
MsgBox TypeName(DateBeg)
MsgBox DateBeg

cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & Worksheets("Config").Cells(3, 2) & "Project.mdb; Jet OLEDB:Database;"
cn.Open ConnectionString

DateBeg = CDate(UserForm.TextBox1)
MsgBox TypeName(DateBeg)
MsgBox DateBeg

rs.Open "SELECT * FROM Itog WHERE CDate(BegProekt) >" & DateBeg & ", cn, adOpenDynamic, adLockBatchOptimistic
 'rs.Open "SELECT * FROM Itog WHERE BegProekt >" & CDate(UserForm.TextBox1) & ", cn, adOpenDynamic, adLockBatchOptimistic'

End Sub

Private Sub CommandButton1_Click()

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim cntrl As String
Dim cl As String

cl = ComboBox2
cntrl = "UserForm." & UserForm.ActiveControl.Name & ".Text"
MsgBox cntrl
MsgBox cl

cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=C:\TMP\Project.mdb; Jet OLEDB:Database;"
cn.Open ConnectionString
'rs.Open "SELECT * FROM Itog WHERE id1='" & cl & "' AND id1 IS NOT NULL ORDER BY 1", cn, adOpenDynamic, adLockBatchOptimistic
rs.Open "SELECT * FROM Itog WHERE id1 like '" & cntrl & "' AND id1 IS NOT NULL ORDER BY 1", cn, adOpenDynamic, adLockBatchOptimistic

ActiveSheet.Range("B8").CopyFromRecordset rs

rs.Close
cn.Close
End Sub

rs.Open "SELECT * FROM Itog WHERE id1='" & cl & "' AND id1 IS NOT NULL ORDER BY 1", cn, adOpenDynamic, adLockBatchOptimistic

rs.Open "SELECT * FROM Itog WHERE id1 like '" & cntrl & "' AND id1 IS NOT NULL ORDER BY 1", cn, adOpenDynamic, adLockBatchOptimistic