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

Period = CStr(Period)

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 Extract_Unique()
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        'On Error Resume Next
        For Each vItem In Worksheets("Отчет").Range(Cells(1, 6), Cells(Cells(Rows.Count, 1).End(xlUp), 6)).Value
            'Cells(Rows.Count, 1).End(xlUp) – определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then Worksheets("Test").Cells(1, 1).Resize(li).Value = avArr
End Sub

Set rVals = Worksheets("Отчет").Range(Cells(12, 6), Cells(i, 6))

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

            Worksheets("Свод").PivotTables("СводнаяТаблица3").ChangePivotCache ActiveWorkbook. _
            PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataArea, _
            Version:=xlPivotTableVersion14) ' обновление источника сводной таблицы

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
            MsgBox (DataArea)

Dim DataArea As Range
 
Set DataArea = Worksheets("Реестр подключений").Range("A1").CurrentRegion

MsgBox (DataArea)

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 = Worksheets("Свод").Cells(Rows.Count, 1).End(xlUp).Row
lLastRowPT42 = Worksheets("Свод").Cells(Rows.Count, 2).End(xlUp).Row
lLastRowPT41 = Worksheets("Реестр подключений").Cells(Rows.Count, 1).End(xlUp).Row
lLastRowPT42 = Worksheets("Реестр подключений").Cells(Rows.Count, 2).End(xlUp).Row
 
MsgBox (lLastRowPT41 & "  " & lLastRowPT42)