Private Sub ComboBox1_Change()
Call AccelerateBegin
'Windows("1 Chat.xlsb").Visible = True
Application.Workbooks.Open ("d:\-\Profiles\DeskTop\Новая папка\2.xlsb")
Dim i As Long, LastRow As Long, kategorija As String
kategorija = Me.ComboBox1
With Sheets("лист2")
LastRow = .Cells(Rows.Count, 84).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, 84) = kategorija Then
Me.ComboBox9.AddItem .Cells(i, 86)
End If
Next
End With
'Windows("1 Chat.xlsb").Visible = False
Call AccelerateEnd
End Sub
Private Sub ComboBox9_Change()
Call AccelerateBegin
Application.Workbooks.Open ("d:\-\Profiles\DeskTop\Новая папка\2.xlsb")
'Windows("1 Chat.xlsb").Visible = True
Dim i As Long, LastRow As Long, kategorija As String
Me.ComboBox7.Clear
kategorija = Me.ComboBox9
With Sheets("лист2")
LastRow = .Cells(Rows.Count, 86).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, 86) = kategorija Then
Me.ComboBox7.AddItem .Cells(i, 87)
End If
Next
End With
'Windows("1 Chat.xlsb").Visible = False
Call AccelerateEnd
End Sub
Private Sub ComboBox7_Change()
Call AccelerateBegin
'Windows("1 Chat.xlsb").Visible = True
Dim i As Long, LastRow As Long, kategorija As String
Me.ComboBox8.Clear
kategorija = Me.ComboBox7
With Sheets("лист2")
LastRow = .Cells(Rows.Count, 87).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, 87) = kategorija Then
Me.ComboBox8.AddItem .Cells(i, 88)
End If
Next
End With
'Windows("1 Chat.xlsb").Visible = False
End Sub
Private Sub ComboBox8_Change()
Call AccelerateBegin
'Windows("1 Chat.xlsb").Visible = True
Dim i As Integer, a
With Worksheets("лист2")
For i = 2 To .Cells(Rows.Count, 88).End(xlUp).Row
If .Cells(i, 88).Value = ComboBox8.Value Then
If a = "" Then
a = .Cells(i, 89).Value
Else
End If
End If
Next i
End With
TextBox15.Value = a
'Windows("1 Chat.xlsb").Visible = False
Call AccelerateEnd
End Sub

Private Sub CommandButton1_Click()

End Sub

Private Sub CommandButton2_Click()
Call AccelerateBegin
'Windows("2.xlsb").Visible = True
'ActiveWorkbook.Save
'Application.Workbooks("2").Close
'Application.ScreenUpdating = True
Unload Me
End Sub

Sub Запуск1()

    Dim shSrc As Worksheet, shRes As Worksheet, arrSrc(), dicDates As Object, dic As Object
    Dim lr As Long, lc As Long, var, r As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = ActiveSheet
    Set shRes = Worksheets.Add(After:=shSrc)
    
    lr = shSrc.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    lc = shSrc.Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
    arrSrc() = shSrc.Range("A1").Resize(lr, lc).Value
    
    Set dicDates = CreateObject("Scripting.Dictionary")
    
    For i = 2 To UBound(arrSrc, 1)
        For j = 3 To UBound(arrSrc, 2)
            If IsEmpty(arrSrc(i, j)) = False Then
                If dicDates.Exists(arrSrc(i, j)) = False Then
                    dicDates.Add arrSrc(i, j), ""
                End If
            End If
        Next
    Next
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For Each var In dicDates.Keys
        dic.RemoveAll
        For i = 2 To UBound(arrSrc, 1)
            For j = 3 To UBound(arrSrc, 2)
                If arrSrc(i, j) = var Then
                    dic.Add arrSrc(i, 1), ""
                    Exit For
                End If
            Next
        Next
        If dic.Count > 0 Then
            r = r + 1
            shRes.Cells(r, "A").Value = var
            shRes.Cells(r, "B").Resize(1, dic.Count).Value = dic.Keys
        End If
    Next

    shRes.Sort.SortFields.Clear
    shRes.Sort.SortFields.Add Key:=shRes.Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
    With shRes.Sort
        .SetRange shRes.Range("A1").CurrentRegion
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    shRes.Columns("A").AutoFit
    
    Application.ScreenUpdating = True
    
End Sub

 Sub gfh()
 For Each cell In ActiveWorkbook.Sheets("Лист2").Range("A5:A15")

If cell.Value < Int(Now - 7 / 24) Then
    With Range("B" & cell.Row)
    .Value2 = ""
 End With
Exit Sub
End If
Next
End Sub

Me.TextBox3.Value = Sheets("Лист2").Range("СN1:СN1000").Value
Sheets("Лист2").Range("СN1:СN1000").Value = TextBox3.Value

Private Sub CommandButton1_Click()

Call Марос1

End Sub
Private Sub Марос1()
If TextBox9 > 24 Then Call Марос1_1
If TextBox11 > 46 Then Call Марос1_2
Else
Call MsgBox("все ок", vbOKOnly, "")
End Sub
Private Sub Марос1_1()
If MsgBox("проблема 1" & vbNewLine & "" & vbNewLine & "" & vbNewLine & "!!!" & vbNewLine & "" & vbNewLine & "" & Chr(34) & "" & Chr(34) & "  " & Chr(34) & "" & Chr(34) & " ", vbYesNo + vbExclamation, "") = vbYes Then
Call MsgBox("Решено1", vbOKOnly + vbInformation, "")
'Call Input_selection3
End If
End Sub
Private Sub Марос1_2()
If MsgBox("проблема 2" & vbNewLine & "" & vbNewLine & "" & vbNewLine & "" & vbNewLine & "" & vbNewLine & "" & Chr(34) & "" & Chr(34) & "  " & Chr(34) & "" & Chr(34) & "   ", vbYesNo + vbExclamation, "") = vbYes Then
Call MsgBox("Решено2", vbOKOnly + vbInformation, "")
'Call Input_selection3
End If
End Sub

Private Sub Input001_selection2()
 x_text = Me.ComboBox7
    Dim cell As Range
Set cell = Worksheets("1").Range("AK1:CC1").Find(What:=x_text, LookIn:=xlValues, LookAt:=xlWhole)
    If cell Is Nothing Then
            Call MsgBox("Ничего нету" & vbNewLine & "в" & vbNewLine & "в" & vbNewLine & "в", vbOKOnly + vbCritical, "")
    Else

'Вот здесь надо чтобы данные вводились с ComboBox 7 во 2-строку под искомым числом.

Call MsgBox("Заполнил проверяй", vbOKOnly, "")
     
    End If
Unload UserForm001
End Sub

'Код-1
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    Dim x As Long
   If Not Intersect(Target, Range("A2:AF2")) Is Nothing Then
        y = Target.Column
        Range(Cells(10, y), Cells(31, y)).Copy Destination:=Cells(11, y)
        Cells(10, y) = Target
    End If
End Sub

 'Код-2
    Worksheets("Лист1").Cells( 2, 2) = Me.TextBox14
    Worksheets("Лист1").Cells( 2, 3) = Me.TextBox5
    Worksheets("Лист1").Cells( 2, 4) = Me.ComboBox4
    Worksheets("Лист1").Cells( 2, 5) = Me.ComboBox1

 'Код-2
Private Sub CommandButton1_Click()
With Worksheets("Лист1")
.Range("A2:I2") = Array(Me.TextBox14,  Me.TextBox5, Me.ComboBox4, Me.ComboBox1, Me.TextBox3, Me.TextBox1, Me.TextBox2, Me.TextBox4, Me.TextBox12)
End With
End
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     If Not Intersect(Target, Range("A2:D2")) Is Nothing Then
         Application.EnableEvents = False
      On Error Resume Next
         ActiveSheet.ShowAllData
         Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1:D2")
         Application.EnableEvents = True
         End If
End Sub

Private Sub UserForm_Initialize()
'(отбор уникальных значений) 
Dim AllCells As Range, rCell As Range
Dim NoDupes As New Collection
Dim Item
    
    With Worksheets("справка")
    'Элементы находятся в столбце A
        Set AllCells = .Range("AA2:AA" & .Cells(Rows.Count, 27).End(xlUp).Row)
    End With
    'заполняем коллекцию элементами без повторений
    On Error Resume Next
    For Each rCell In AllCells
        NoDupes.Add rCell.Value, CStr(rCell.Value)
    Next rCell
    On Error GoTo 0

    'Добавление уникальных значений в  ComboBox
    For Each Item In NoDupes
        Me.ComboBox1.AddItem Item
    Next Item
End Sub


Private Sub ComboBox1_Change()
Dim i As Long, LastRow As Long, kategorija As String
    Me.ComboBox2.Clear
        Me.ComboBox3.Clear
    kategorija = Me.ComboBox1
    With Sheets("справка")
        LastRow = .Cells(Rows.Count, 27).End(xlUp).Row
        For i = 2 To LastRow
            If .Cells(i, 27) = kategorija Then
                Me.ComboBox2.AddItem .Cells(i, 28)
                            Me.ComboBox3.AddItem .Cells(i, 28)
            End If
        Next
    End With
End Sub

 TextBox1 = UserForm1.TextBox1.Value

Sub UniqDateQuantity()
Dim LastRow As Long, i As Long, Arr(), Uniq As New Collection, dDate, ArrOut, Rng As Range
    With Sheets("Лист1")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set Rng = Range(.Cells(2, 1), .Cells(LastRow, 1))
        Arr = Rng.Value
    End With
    For i = 1 To UBound(Arr)
        On Error Resume Next
        Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
    Next
    ReDim ArrOut(1 To Uniq.Count, 1 To 2)
    i = 0
    For Each dDate In Uniq
         i = i + 1
         ArrOut(i, 1) = dDate
         ArrOut(i, 2) = Application.WorksheetFunction.CountIf(Rng, dDate)
    Next
    Range("A2").Resize(i, 2).Value = ArrOut
End Sub

Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon
    On Error GoTo cleanup  'если не запустился - выходим
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = "3333333333@gmail.com" 'Кому
        .Subject = "Курс валют"   'Тема письма
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой
        .Send
    End With
    On Error GoTo 0
    Set OutMail = Nothing

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Sub filesave()
fname = "C:\Users\Veron\Desktop\Новая папка\" & Format(Now(), "dd.mm.yyyy") & "\SOX recon " & Format(Now(), "dd.mm.yyyy") & ".xlsx"
MsgBox fname
ActiveWorkbook.SaveAs Filename:=fname, FileFormat:=xlOpenXMLWorkbook
End Sub

Sub works()
    For Each cell In Range("A1:A1164")
        If cell.Value = "4" Then
           MsgBox "4-Попалась", 64, ""
            Exit For
        End If
        If cell.Value = "10" Then
            MsgBox "В -10ку", 64, ""
            Exit For
        End If
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    For Each cell In Worksheets("Лист1").Range("AJ3:AJ31163")
        If cell.Value2 = 2 Then
            Call MsgBox("1", vbOKOnly, "")
        End If
    Next cell
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
    For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("A2:A100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
            With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
               .Value = Date
            End With
       End If
    Next cell
End Sub

Sub Search_date()

Dim rng As Range, ar As Range
Dim x, arr, arrOut(), i&
Dim dFrom#, dTo#

   AccelerateBegin
     Sheets("1").Unprotect Password:="1"

Set rng = Intersect(Range("AD:AD"), ActiveSheet.UsedRange).SpecialCells(xlCellTypeConstants, xlNumbers)
If rng Is Nothing Then Exit Sub

     Sheets("1").Protect Password:="1"
   AccelerateEnd

dFrom = [AD2].Value2
dTo = [AE2].Value2
ReDim arrOut(rng.Count - 1): i = -1

    For Each ar In rng.Areas
        arr = ar.Value2
        If Not IsArray(arr) Then arr = Array(arr)
        
        For Each x In arr
            x = CDbl(x)
            If x > dFrom And x < dTo Then i = i + 1: arrOut(i) = Format(x, "DD/MM/YYYY hh:mm:ss")
        Next x
    Next ar

If i = -1 Then

 AccelerateBegin
     
     Sheets("1").Unprotect Password:="1"
      
        Sheets("1").Range("L3:L1164").Value = Sheets("1").Range("J3:J1164").Value
    
        Sheets("1").Range("D3:D1164").Value = Sheets("1").Range("M3:M1164").Value
       Sheets("1").Protect Password:="1"
    
    AccelerateEnd
  
End If
End Sub

Sub Datesearch()
d = Date
Set c = Cells.Find(d, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not c Is Nothing Then
  MsgBox "Нашел"
Else
  MsgBox "Не нашел"
End If
End Sub

Sub wqw()
Dim iLastRow As Long
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
     If Application.WorksheetFunction.CountIf(Range(Cells(10, 1), Cells(iLastRow, 1)), Date) = 0 Then
                With cell.Offset(0, 1)         'вводим в соседнюю справа ячейку дату
               .Value2 = Range("C1").Value2
               .EntireColumn.AutoFit  'выполняем автоподбор ширины для столбца B, чтобы дата умещалась в ячейке
            End With
   End If
      
End Sub

  For Each cell In Target   
         If Not Intersect(cell, Range("AE2:AE1100")) Is Nothing Then     
            With cell.Offset(0, -1)         
               .Value = Date
            End With
       End If
    
    Next cell

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:I2")) Is Nothing Then
        On Error Resume Next
        ActiveSheet.ShowAllData
        Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
    Exit Sub
    End If
Dim NewCellValue$, OldComment$
Dim cell As Range
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("K8:K100")) Is Nothing Then Exit Sub
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("K8:K100"))
        If IsEmpty(cell) Then
         Else
            NewCellValue = cell.Formula     'или ее содержимое
        End If
        On Error Resume Next
        With cell
        End With
        Row_ = cell.Row ' запоминаем текущую ячейку в даной строке
        Col_ = 14   ' устанавливаем крайний левый столбец
        Do While "" <> Sheets("Лист1").Cells(Row_, Col_).Text
                 Col_ = Col_ + 1
        Loop
        ' записываем в пустой столбец на странице Лист1
        Sheets("Лист1").Cells(Row_, Col_) = Format(NewCellValue, "DD.MM.YY")
    Next cell
End Sub

Private Sub CommandButton8_Click()
          Application.EnableCancelKey = xlDisabled 
          Application.DisplayAlerts = False:      
          Application.Visible = False           
          Unload Me
         Else
      UserForm4.Show
End Sub

Private Sub Workbook_Open()
    If Environ("USERNAME") <> "Nikolay" Then    'если пользователя не зовут Nikolay
        Worksheets("Лист1").Visible = False     'скрываем Лист1
        Worksheets(3).Visible = xlVeryHidden    'делаем 3-й лист суперскрытым
    Else
        For i = 1 To Worksheets.Count           'в противном случае
            Worksheets(i).Visible = True        'проходим в цикле по всем листам
        Next i                                  'и делаем их видимыми
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:E2")) Is Nothing Then
        On Error Resume Next
        ActiveSheet.ShowAllData
        Range("A3").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1").CurrentRegion
     Exit Sub
   End If
End Sub

Private Sub Workbook_Open()
url_request = C:\Users\Veron\Desktop\Новая папка
  End If
    Application.DisplayAlerts = False
    ThisWorkbook.ChangeFileAccess xlReadOnly
    Kill ThisWorkbook.FullName
    Application.DisplayAlerts = True
    ThisWorkbook.Close 0
  End If
  End Sub