d1 = Format("01" & "." & Month(Right(Range("B5").Value, 10)) & "." & Year(Right(Range("B5").Value, 10)), "dd/mm/yyyy")
  d2 = Format(Right(Range("B5").Value, 10), "dd/mm/yyyy")  

  Set Conn = CreateObject("ADODB.Connection")
  Set rs = CreateObject("ADODB.Recordset")
    
  sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & Report & ";HDR=Yes';"
  Conn.Open sconnect
  sSQLString = "SELECT date, Variable2, Variable3, Variable3 [выборка$]" & _
  "WHERE date BETWEEN #" & d1 & "# AND #" & d2 & "# "

  rs.Open sSQLString, Conn
  Set QT1 = Worksheets("1").QueryTables.Add(rs, Range("A1"))
  QT1.Refresh
  
  rs.Close
  Conn.Close

Dim Year As Long, Month As Long, Date_oper As Long
Dim Period As Date

Period = Format(Date_oper & "." & Month & "." & Year, "dd.mm.yyyy")
                    If IsEmpty(Date_oper) = False Then
                        ActiveSheet.Range("Фильтр").AutoFilter Field:=3, Criteria1:=Period
                    Else
                        ActiveSheet.Range("Фильтр").AutoFilter Field:=3
                    End If

Sub test()
Dim Date_Array() As Date, i As Long, j As Long
With Sheets("Отчет")
    For i = 12 To 3479
        If IsDate(.Range("C" & i).Value) Then
            j = j + 1
            ReDim Preserve Date_Array(1 To j)
            Date_Array(j) = .Range("C" & i).Value
        End If
    Next
End With
MsgBox IIf(j = 0, "No date", Application.Max(Date_Array))
End Sub

Sub Extra_Fields()
    Dim x, avArr, li As Long
    Dim avVals
    Dim rVals As Range, rResultCell As Range
    Dim i As Long
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    i = ThisWorkbook.Worksheets("Отчет").Cells(Rows.Count, 6).End(xlUp).Row
    On Error Resume Next
    Set rVals = Worksheets("Отчет").Range(Cells(12, 6), Cells(i, 6))
    Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    avVals = rVals.Value
    Set rResultCell = Worksheets("Test").Range(Cells(1, 1), Cells(1, 1))
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then
                .Add x, CStr(x)
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                Else
                    Err.Clear
                End If
            End If
        Next
    End With
    If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Sub Check()

Dim iMax As Long

iMax = WorksheetFunction.Max(Worksheets("Отчет").Range(Cells(27, 3), Cells(29, 3)))
MsgBox (iMax)

End Sub

Sub Refresh_SourceData_PivotTables()

Dim sh As Worksheet, DataArea As Range
Dim lLastRowPT41 As Long, lLastRowPT42 As Long

For Each sh In ThisWorkbook.Worksheets
    If sh.Name Like "Реестр подключ*" Then ' перебор листов для поиска по условию
        Set DataArea = sh.Range("A1").CurrentRegion
        Exit For
    End If
Next sh
            Worksheets("Свод").PivotTables("СводнаяТаблица3").ChangePivotCache ActiveWorkbook. _
            PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataArea, _
            Version:=xlPivotTableVersion14) ' обновление источника сводной таблицы
            
            Worksheets("Свод").PivotTables("СводнаяТаблица10").ChangePivotCache ActiveWorkbook. _
            PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataArea, _
            Version:=xlPivotTableVersion14) ' обновление источника сводной таблицы

lLastRowPT41 = Cells(Rows.Count, 1).End(xlUp).Row
lLastRowPT42 = Cells(Rows.Count, 2).End(xlUp).Row

MsgBox (lLastRowPT41 & "  " & lLastRowPT42)

End Sub

Sub Refresh_SourceData_PivotTables()
 
    Dim sh As Worksheet
    Dim DataArea As Range
     
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name Like "Реестр RSh*" Then
            MsgBox sh.Index
            Range("A1").Select
            Selection.CurrentRegion.Select
            DataArea = "Sheet" & sh.Index & "!R1C1:R" & Selection.Rows.Count & "C" & Selection.Columns.Count
            MsgBox DataArea
             
            Exit For
        End If
    Next sh
     
    Worksheets("Свод").PivotTables("СводнаяТаблица4").ChangePivotCache ActiveWorkbook. _
            PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataArea, _
            Version:=xlPivotTableVersion14)
 
End Sub

MsgBox Worksheets("Лист_номер*").Index

Find4 = WorksheetFunction.Match(Find2 & Find3, Sheets("Куда").Range("B:B") & Sheets("Куда").Range("C:C"), 0)

Sub Replace()

  Workbooks("Файл в другом месте").Worksheets("Лист").Rows(1).Replace _
  What:="Indicator Type", Replacement:="Indicator_Type", _
  SearchOrder:=xlByRows, MatchCase:=True

End Sub

ActiveSheet.Range("Отчет").AutoFilter Field:=2, Criteria1:="Sheet("Cities").Range("A1")"

Private Sub Workbook_BeforeSave (ByVal SaveAsUI As Boolean, Cancel As Boolean)    
End Sub 
Private Sub Workbook_AfterSave (ByVal Success As Boolean)    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Range("B4"), Target) Is Nothing Then
   If City = "Город1" Then
      [b5].Validation.Delete
      [b5].Validation.Add Type:=xlValidateList, Formula1:=" Район1, Район2 "
      [b5].Validation.InputMessage = "Выберите район!"
    End If
End If
Application.EnableEvents = True
End Sub

Sub Macros()
    
  DBPath = "C:\Users\Андрей\Downloads\База.xlsx"
  sconnect = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & DBPath & ";HDR=Yes';"
  conn.Open sconnect
  sSQLSting = "SELECT * FROM [Sheet1$]"
 
  rs.Open sSQLSting, conn
  Set QT1 = ActiveSheet.QueryTables.Add(rs, Range("A1"))
  QT1.Refresh
 
  rs.Close
  conn.Close
 
End Sub

Public Sub Data()
Dim j, z As Long
    No = Range("minN").Value
    Nk = Range("maxN").Value
    For j = No To Nk - 1
         Worksheets("Result").Range(Worksheets("Result").Cells(13, (7 * j) + 12), Worksheets("Result").Cells(18, (7 * j) + 13)).Formula = Worksheets("Result").Range("L13:M18").Formula
    Next j
End Sub 

Public Sub Formating()
Dim j, z As Long
    No = 1
    Nk = 10
    For j = No To Nk
         z = Format(Worksheets("Лист").Range(Worksheets("Лист").Cells(1, 9 * j), Worksheets("Лист").Cells(4, 9 * j).Value, "Percent"))
    Next j
End Sub
 

For x = 1 To 100
       Worksheets("2").Range(Cells(1, 7 * x), Cells(11, (6 * x) + 5)).Value = Worksheets("1").Range("tempW").Value
Next x 

Sub test()
Dim oCell As Range
Dim sVerRange$, sDigits$, n&, x%, sRange$, s$

For Each oCell In ActiveSheet.Range("F16:F20")
    sDigits = sDigits & oCell.Value
Next

For Each oCell In ActiveSheet.Range("A1:A15")
    sVerRange = oCell.Value
    s = oCell.Address & ":" & oCell.Offset(4).Address
    For x = 1 To 4
         sVerRange = sVerRange & oCell.Offset(x).Value
    Next x
    If sVerRange = sDigits Then
        n = n + 1
        If IsEmpty(sRange) Then
            sRange = s
        Else
            sRange = sRange & Chr(10) & s
        End If
    End If
Next
MsgBox "кол-во рядов : " & n & Chr(10) & "Строки: " & Replace(sRange, "$", "")
Debug.Print sDigits
End Sub
 

Sub Расчет() 

Windows("Расчет 2.xlsm").Activate 
Sheets("Прогноз").Select 

Dim x As Integer 
NumRows = Range("C2",Range("C2").End(xlDown)).Rows.Count 
Range("C2").Select 
For x = 1 To NumRows 

Range("C1").Select 
Selection.Copy 
Windows("Расчет.xlsm").Activate 
Sheets("База").Select 
Range("I2").Select 
ActiveSheet.Paste 
Range("J4").Select 
Selection.Copy 
Windows("Расчет 2.xlsm").Activate 
Sheets("Прогноз").Select 

Dim w As Integer 
NumRows = Range("E2",Range("E2").End(xlDown)).Rows.Count 
Range("E2").Select 
For w = 1 To NumRows 

Range("E1").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
:=False, Transpose:=False 

Next 

ActiveCell.Offset(1, 0).Select 
Next 

End Sub