Sub QueryDataModelWithDAX()
    
    Dim conn As Object, c As WorkbookConnection
    Dim rs As Object
    Dim strConn As String
    Dim strDAX  As String
    
    Set c = ThisWorkbook.Connections("ThisWorkbookDataModel")

    Set conn = c.ModelConnection.ADOConnection

    ' DAX-запрос: получить всех клиентов со статусом
    strDAX = "EVALUATE FILTER ( ADDCOLUMNS('Customer' , ""Oblast_name"", RELATED('Oblast'[name])),'Customer'[status_id]=0)"
    
    Set rs = conn.Execute(strDAX)
    
    
     If Not rs.EOF Then rs.MoveFirst
     Dim i As Long, d As Long

     For i = 1 To rs.Fields.Count
        Лист2.Cells(1, i).Value = rs.Fields(i - 1).Name
     Next i
        i = 2
        Do While Not rs.EOF
            For d = 1 To rs.Fields.Count
                Лист2.Cells(i, d) = rs.Fields(d - 1).Value
            Next
            i = i + 1
            rs.MoveNext
        Loop

'    Лист2.Range("A1").CopyFromRecordset rs

    rs.Close
    conn.Close
End Sub

Private Sub worksheet_calculate()
Dim Crit2 As Variant
Dim sh As Worksheet, sh2 As Worksheet

    Set sh = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    Set TargetTab = sh2.ListObjects("Table2")

    Dim arr As Variant, rng As Range, r As Range
    On Error Resume Next
    Set rng = sh.ListObjects(1).ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    ReDim arr(0 To rng.Cells.Count - 1)
    Dim i As Long
    i = 0
    For Each r In rng.cells
        arr(i) = r.Text
        i = i + 1
    Next r

    With sh.AutoFilter.Filters(1)
        If .On Then
            On Error Resume Next
            TargetTab.AutoFilter.ShowAllData
             On Error GoTo 0
            TargetTab.Range.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
        End If
    End With


End Sub

Sub FormulaPlusZnacenie()
'
' FormulaPlusZnacenie Макрос
' В ячейку записывается формула и ее расчет. Возвращает формулу и рассчитанное ее значение.
'
' Сочетание клавиш: Ctrl+f
'
    Dim fRZn As String
 
    fRZn = InputBox("1. Скопируйте в буфер содержащуюся в ячейке формулу;" & Chr(10) & _
                    "2. Выберите ячейку, в которую нужно вставить формулу и ее расчетное значение;" & Chr(10) & _
                    "3. Запустите <Ctrl + f> данный макрос и в окно ввода вставте содержимое буфера.", "Скопируйте из буфера:")
 
    'ActiveCell.FormulaR1C1 = "=TEXT(""ОКРУГЛ(0,55*1,75*1,15;3)"","""")&"" = ""&ROUND(0.55*1.75*1.15,3)"
    Dim g
    g = EvalLocal("=" & fRZn)
    ActiveCell.FormulaLocal = "=" & Chr(34) & fRZn & """ " & "=" & g
     
End Sub

Function EvalLocal(FormulaLocal As String, Optional Sh As Worksheet)
 If Sh Is Nothing Then Set Sh = ActiveSheet
 With Sh.Names.Add("My.Temporary.Name", RefersToLocal:=FormulaLocal)
   EvalLocal = Evaluate(.RefersTo)
   .Delete
 End With
End Function