Sub Поиск()
Set Rng1 = Columns("C:C").Find(Range("A1"))

MsgBox Rng1.Row

End Sub

HAVING (PL.РабочаяДата>='2023-01-01') AND (Transport.Колонна like ('а/к %'))

HAVING (PL.РабочаяДата>='2023-01-01') AND (Transport.Колонна 'а/к %')

Application.DisplayAlerts = False

Private Sub CommandButton1_Click()
ActiveCell = 8
AppActivate Application
End Sub

Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Range("B1:M35").Copy
 
    'создаем новое пустое сообщение в Outlook
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    
    With OutMail
        .To = "vasya@pupkin.com"
        .Subject = "Выполнение графиков движения автобусов за " & ThisWorkbook.ActiveSheet.Name
        .Body = "Здравствуйте! Высылаю данные о выполнении графиков движения автобусов за " & ThisWorkbook.ActiveSheet.Name & "г."
        'вместо Send можно использовать Display, чтобы посмотреть сообщение перед отправкой
    End With
    
    OutMail.Display
    
AppActivate Title:="Выполнение графиков движения автобусов за Январь 2022 - Сообщение (HTML)"
    
'  Перемещаю курсор
    For i = 1 To 100
SendKeys ("{right}")
    Next
      
    Selection.Paste

    On Error GoTo 0
    Set OutMail = Nothing

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

SELECT REPLACE(`TDSheet$`.Номер & '-','-','') AS 'Номер' FROM `TDSheet$` `TDSheet$`

SELECT `TDSheet$`.`Дата ПЛ` AS 'Дата'
FROM `F:\Даты.xls`.`TDSheet$` `TDSheet$`

Sub Запрос()
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "ODBC;DSN=Excel Files;DBQ=F:\Даты.xls;DefaultDir=F:;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandText = Array( _
        "SELECT `TDSheet$`.`Дата ПЛ` AS 'Дата'" & Chr(13) & "" & Chr(10) & "FROM `F:\Даты.xls`.`TDSheet$` `TDSheet$`" _
        )
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Таблица_Запрос_из_Excel_Files"
        .Refresh BackgroundQuery:=False
    End With
End Sub

Public V8 As Object
Dim v8con As New V83.COMConnector

Public Sub v8connect()
Set V8 = v8con.Connect("Srvr=""Feldman"";Ref=""alfa_trade_2005"";Usr=""ИвановВС"";Pwd=""""")
End Sub

 Set V8 = v8con.Connect("Srvr=""Feldman"";Ref=""alfa_trade_2005"";Usr=""ИвановВС"";Pwd=""""")

Function СцепитьЕсли3(Диапазон_сцепления As Range, Диапазон1 As Range, Критерий1 As String, Диапазон2 As Range, Критерий2 As String, Диапазон3 As Range, Критерий3 As String)
    Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
     
    'если диапазоны проверки и склеивания не равны друг другу - выходим с ошибкой
    If Диапазон1.Count <> Диапазон_сцепления.Count Or Диапазон2.Count <> Диапазон_сцепления.Count Then
        СцепитьЕсли3 = CVErr(xlErrRef)
        Exit Function
    End If
     
    'проходим по все ячейкам, проверяем все условия и собираем текст в переменную OutText
    For i = 1 To Диапазон1.Cells.Count
        If Диапазон1.Cells(i) = Критерий1 And Диапазон2.Cells(i) = Критерий2 And Диапазон3.Cells(i) = Критерий3 Then
            OutText = OutText & Диапазон_сцепления.Cells(i) & Delimeter
        End If
    Next i
     
    'выводим результаты без последнего разделителя
    СцепитьЕсли3 = Left(OutText, Len(OutText) - Len(Delimeter))
End Function

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) As String
    Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
    If Диапазон.Count > 1 Then
        avDateArr = Intersect(Диапазон, Диапазон.Parent.UsedRange).Value
        avRezArr = Intersect(Диапазон_сцепления, Диапазон_сцепления.Parent.UsedRange).Value
        If Диапазон.Rows.Count = 1 Then
            avDateArr = Application.Transpose(avDateArr)
            avRezArr = Application.Transpose(avRezArr)
        End If
    Else
        ReDim avDateArr(1, 1): ReDim avRezArr(1, 1)
        avDateArr(1, 1) = Диапазон.Value
        avRezArr(1, 1) = Диапазон_сцепления.Value
    End If
    lUBnd = UBound(avDateArr, 1)
    'Определяем вхождение операторов сравнения в Критерий
    Dim objRegExp As Object, objMatches As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"
    Set objMatches = objRegExp.Execute(Критерий)
    'Если есть вхождения
    If objMatches.Count > 0 Then
        Dim sStrMatch As String
        sStrMatch = objMatches.Item(0)
        Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
        Select Case sStrMatch
        Case "="
            For li = 1 To lUBnd
                If avDateArr(li, 1) = Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <> Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">=", "=>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) >= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<=", "=<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">"
            For li = 1 To lUBnd
                If avDateArr(li, 1) > Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) < Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        End Select
    Else    'Если нет вхождения
        For li = 1 To lUBnd
            If avDateArr(li, 1) Like Критерий Then
                If Trim(avRezArr(li, 1)) <> "" Then _
                   sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
            End If
        Next li
    End If
    
    If БезПовторов Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(sStr, Разделитель)
        On Error Resume Next
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(li), sTmpStr(li)
        Next li
        sStr = ""
        sTmpStr = oDict.keys
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li)
        Next li
    End If
    СцепитьЕсли = sStr
End Function

Private Sub AddListItem2()
    Dim r As Range
        Set r = Sheets("Справочник цен").Range("N2:N16")
        danIn = r.Value
    ListBox2.List = danIn
    
End Sub

Sub ФильтрПоЯчейке()
On Error GoTo конец
Selection.AutoFilter field:=ActiveCell.Column - ActiveSheet.AutoFilter.Range.Column + 1, Criteria1:=ActiveCell
конец:
End Sub

Sub ДФильтрПоЯчейке()
dt = Format(ActiveCell, ActiveCell.NumberFormat)
If IsDate(ActiveCell) Then
Selection.AutoFilter field:=ActiveCell.Column - ActiveSheet.AutoFilter.Range.Column + 1, Criteria1:=dt
Else
Selection.AutoFilter field:=ActiveCell.Column - ActiveSheet.AutoFilter.Range.Column + 1, Criteria1:=ActiveCell
End If
End Sub

DSN=Файлы Excel;DBQ=Z:\ORG\UPRDIR\ATU\Tranzit\Шишигин\Запросы\Тех отчет_АТУ ПП_ за август_2016(3).xlsm;DefaultDir=Z:\ORG\UPRDIR\ATU\Tranzit\Шишигин\Запросы;DriverId=790;MaxBufferSize=2048;PageTimeout=5;

Sub ЧислоИзОбласти()
    With ActiveSheet.Range("A1:A10")
        arr = .Value
        .NumberFormat = "General"
        .Value = arr
    End With
End Sub

Sub Макрос1()
    Columns("F:F").Insert Shift:=xlToRight 'вставить строку
    Range("F1") = "Дата"
X = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'последняя строка
    Range("F2:F" & X) = "=RC[-1]+0"
    Range("F2:F" & X).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    Range("F2:F" & X).Copy Range("F2:F" & X)
    Range("F2:F" & X).Copy
    Range("F2:F" & X).PasteSpecial Paste:=xlPasteValues
    Columns("F:F").EntireColumn.AutoFit
    Columns("E:E").Delete Shift:=xlToLeft
End Sub

Sub Сортировка()
    
On Error Resume Next
    Application.DisplayAlerts = False ' Выключаю сообщение об ошибке
    
    ActiveWorkbook.Worksheets("Сверка").AutoFilter.Sort.SortFields.Clear
    ActiveSheet.ShowAllData
    
   iRow = Sheets("Сверка").Cells(Rows.Count, 1).End(xlUp).Row  'последняя строка
    Rows("4:" & iRow).Delete Shift:=xlUp

    

    Workbooks.Open Filename:="C:\расхождения с гпн.xls"
    Columns("A:V").Copy
    Windows("Кнопка мигает.xlsm").Activate
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollColumn = 21
    Windows("расхождения с гпн.xls").Activate
    ActiveWindow.Close
    
     iRow = Sheets("Сверка").Cells(Rows.Count, 1).End(xlUp).Row  'последняя строка
   Range("W2:AL2").AutoFill Destination:=Range("W2:AL" & iRow)
    
'Сортирую фильтрую
    ActiveWorkbook.Worksheets("Сверка").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Сверка").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("X2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Сверка").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("AA2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Сверка").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1").AutoFilter Field:=25, Criteria1:="=2", _
        Operator:=xlAnd
        
    ActiveSheet.Range("$A$1").AutoFilter Field:=38, Criteria1:= _
        "=ИСТИНА", Operator:=xlAnd
        
    ActiveSheet.Range("$A$1").AutoFilter Field:=27, Criteria1:="<>ГПН" _
        , Operator:=xlAnd
        
    ActiveWindow.ScrollColumn = 21
    Range("AA1").Select
    ActiveWindow.SmallScroll Down:=-1000
    
    Application.DisplayAlerts = True ' Включаю сообщение об ошибке
    

    
End Sub

Sub Передел()
    Columns("A:A").Replace What:=".", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows
    Columns("A:A").TextToColumns
End Sub