Sub ИмпортИзOLAP()

Dim Cn As Object
Dim РекордсетИмпорт As Object

Set Cn = CreateObject("ADODB.Connection")
Cn.ConnectionString = "Provider=MSOLAP.3;" & _
    "Integrated Security=SSPI;" & _
    "Persist Security Info=True;" & _
    "Initial Catalog=profit;" & _
    "Data Source=..........................;" & _
    "MDX Compatibility=1;" & _
    "Safety Options=2;" & _
    "MDX Missing Member Mode=Error"
Cn.Open

Set РекордсетИмпорт = CreateObject("ADODB.Recordset")
Set РекордсетИмпорт.activeconnection = Cn
РекордсетИмпорт.Source = "Select {} on 0, [Города].[Город].[Город] on 1 from profit"

РекордсетИмпорт.Open

If Not (РекордсетИмпорт.BOF = True And РекордсетИмпорт.EOF = True) Then
    РекордсетИмпорт.MoveFirst
    
    Do While Not РекордсетИмпорт.EOF
        '...
        РекордсетИмпорт.MoveNext
    Loop
End If

РекордсетИмпорт.Close
Set РекордсетИмпорт = Nothing
Cn.Close
Set Cn = Nothing
End Sub

Sub ВставитьТаблицуИзOLAP()

Dim СтрокаПодключения As String
СтрокаПодключения = "OLEDB;Provider=MSOLAP.4;" & _
    "Integrated Security=SSPI;" & _
    "Persist Security Info=True;" & _
    "Initial Catalog=profit;" & _
    "Data Source=..............;" & _
    "MDX Compatibility=1;" & _
    "Safety Options=2;" & _
    "MDX Missing Member Mode=Error"

Dim ТекстЗапроса As String
ТекстЗапроса = "SELECT {} On 0, [Города].[Города].[Города] ON 1 FROM Profit"

Dim pLO As ListObject
Dim pSheet As Worksheet
Set pSheet = ThisWorkbook.Worksheets.Add
With pSheet.ListObjects.Add(SourceType:=xlSrcExternal, _
        Source:=Array(СтрокаПодключения), _
        Destination:=pSheet.Range("A1")).QueryTable
        .CommandType = xlCmdDefault
        .CommandText = Array(ТекстЗапроса)
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        '.ListObject.DisplayName = "Подключение"
        .Refresh BackgroundQuery:=False
        .WorkbookConnection.Description = "Connection to ИД1"
        .WorkbookConnection.Name = "Query" & Format$(Now, "yyyymmddhhnnss")
End With
End Sub