Err.Clear
Application.DisplayAlerts = False
On Error Resume Next
With Workbooks("forum.xlsm").Connections("my_query").OLEDBConnection
    .BackgroundQuery = False  'or true, up to you
    .Refresh
End With
If Err.Number <> 0 Then GoTo nextx
Debug.Print "обновлено"
nextx:

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'НУЖНО ЧТО БЫ РАБОТАЛО ТАК:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FilterExample1()
    On Error Resume Next
    Dim arr As Variant
 
    ' получает по ссылке массив ARR для фильтрации
    ' и список критериев фильтрации в формате "3=некий текст" (номер столбца, "=", искомое значение)
    ' возвращает двумерный массив с подходящими строками
    temp = Worksheets("Лист2").Range("a1:A3")
    arr = ArrAutofilterEx(Worksheets("Лист1").Range("a1:D20").Value, "1=" & temp)
 
    ' создаем лист, вставляем на него результат
    Worksheets.Add.Range("a1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'РАБОТАЕТ ПО ОДНОМУ КРИТЕРИЮ В СТОЛБЦЕ. В 1 столбце отфильтрует все значения 2
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub FilterExample()
    On Error Resume Next
    Dim arr As Variant
 
    ' получает по ссылке массив ARR для фильтрации
    ' и список критериев фильтрации в формате "3=некий текст" (номер столбца, "=", искомое значение)
    ' возвращает двумерный массив с подходящими строками
    temp = 2
    arr = ArrAutofilterEx(Worksheets("Лист1").Range("a1:D20").Value, "1=" & temp)
 
    ' создаем лист, вставляем на него результат
    Worksheets.Add.Range("a1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Function ArrAutofilterEx(ByRef arr, ParamArray args() As Variant) As Variant
    ' получает по ссылке массив ARR для фильтрации
    ' и список критериев фильтрации в формате "3=некий текст" (номер столбца, "=", искомое значение)
    ' возвращает двумерный массив с подходящими строками
    Dim Index As Long, OK As Boolean, ComparedColumn As Long, res As String
 
    If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical, _
       "Ошибка в функции ArrAutofilter": Exit Function
 
    For Index = LBound(args) To UBound(args)    ' перебираем все параметры фильтрации
        If Not IsMissing(args(Index)) Then
            If GetAutofilterArgument(args(Index), ComparedColumn, res) Then
                If (ComparedColumn > UBound(arr, 2)) Or (ComparedColumn < LBound(arr, 2)) Then _
                   ArrAutofilter = ArrAutofilter & "В массиве нет столбца с номером " & _
                   ComparedColumn & vbNewLine
            Else
                ArrAutofilter = ArrAutofilter & "Неверно сформирована строка фильтрации: " & _
                                args(Index) & vbNewLine
            End If
        Else
            ArrAutofilter = ArrAutofilter & (Index + 1) & "-й аргумент фильтрации отсутствует" & _
                            vbNewLine
        End If
    Next Index
    If Len(ArrAutofilter) Then
        MsgBox ArrAutofilter, vbCritical, "Ошибка в функции ArrAutofilter"
        ArrAutofilterEx = "": Exit Function
    End If
 
    Dim coll As New Collection
    For i = LBound(arr, 1) To UBound(arr, 1)    ' перебираем все строки массива
        OK = True
        For Index = LBound(args) To UBound(args)    ' перебираем все параметры фильтрации
            ' получаем параметры фильтрации
            X = GetAutofilterArgument(args(Index), ComparedColumn, res)
            If Not (arr(i, ComparedColumn) Like res) Then OK = False: Exit For
        Next Index
        If OK Then coll.Add i
    Next i
 
    ' формируем новый массив
    ReDim newarr(1 To coll.Count, LBound(arr, 2) To UBound(arr, 2))
    For i = 1 To coll.Count
        ro = coll(i)
        For j = LBound(arr, 2) To UBound(arr, 2): newarr(i, j) = arr(ro, j): Next j
    Next i
 
    ArrAutofilterEx = newarr
End Function
 
Function GetAutofilterArgument(ByVal arg, ByRef col As Long, ByRef searchStr As String) As Boolean
    col = 0: searchStr = ""
    If UBound(Split(arg, "=")) < 1 Then Exit Function    ' нет знака =
    sCol = Split(arg, "=")(0): If Len(sCol) = 0 Or Not sCol Like String(Len(sCol), "#") Then _
                                  Exit Function  ' номер столбца не соответствует
    searchStr = Mid$(arg, Len(sCol) + 2): col = Val(sCol)
    If col > 0 Then GetAutofilterArgument = True
End Function

Sub Макрос1()
'работает
Worksheets("здесь макро работает").Select

   i = Application.Match(Cells(23, 1), Range("A2:A20"), 0)
   j = Application.Match(Cells(23, 2), Range("B1:G1"), 0)
   Cells(24, 1).Value = Application.Index(Range("B2:G20"), i, j)
End Sub

Sub Макрос1()
Dim pItem As PivotItem
Application.ScreenUpdating = False
With ActiveSheet.PivotTables("Сводная таблица11")
For Each pItem In .PivotFields("[Аптеки].[Компания].[Компания]").PivotItems
If pItem = "[Аптеки].[Компания].&[Офисы]" Then
pItem.Visible = False
Else
pItem.Visible = True
End If
Next
.PivotCache.Refresh
End With
Application.ScreenUpdating = True

End Sub

ActiveSheet.PivotTables("Сводная таблица11").PivotFields( _
"[Аптеки].[Компания].[Компания]").VisibleItemsList = Array( _
"[Аптеки].[Компания].&", "[Аптеки].[Компания].&[Вежа]", _
"[Аптеки].[Компания].&[Астра]", "[Аптеки].[Компания].&[Зафира]")

'строчка кода обновления сводной таблицы, где возможны подвисания
ActiveWorkbook.Connections("Tabular Модель1").Refresh

Sub обработчик_зависаний_макроса()
'если зависнет - попытку выполнения повторить 2 раза.
    For i = 1 To 2
    'время, которым ограничено выполнение части скрипта в цикле
    maxtime_for_macro = Now() + TimeValue("00:00:10")
    a = Timer 'таймер для контроля работы обработчика зависаний макроса
    
        DoEvents 'Передает управление Windows
        Do While Now <= maxtime_for_macro 'нужно выполнять только разрешенное время - 10 сек.
            Application.Wait Now() + TimeValue("00:00:15") 'пример процесса, который выполняется слишком долго (больше 10 сек.)                         
            MsgBox Timer - a & "работает, если выполнение около 10 секунд"  
        Loop

        if maxtime_for_macro - Now  < 10 Then exit For 'если выполняется меньше чем за 10 сек - повтор цикла не нужен
    Next i
End Sub

Sub check()
Dim a As Boolean
a = ActiveWorkbook.Connections("Tabular Модель1")

If a = False Then

End If

Sub Макрос1()
'присвоить переменную для применения в фильтре
Dim d As Integer
d = Sheets("звіт").[B2]

'фильтр
ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=8, Criteria1:= _
    "<d", Operator:=xlAnd
End Sub