Sub ADO_Connect_without_library2()
'без подключение библиотеки ACTIVEX data ojects 6.0
Dim cn As Object, rs1 As Object
Dim strSQL As String
Dim QT As QueryTable

Set cn = CreateObject("ADODB.Connection")
Set rs1 = CreateObject("ADODB.Recordset")
'cn.Provider = "oraOLEDB.Oracle"
cn.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=True;Extended Properties="DSN=CData GoogleBigQuery Source;";Initial Catalog=**********"

On Error GoTo CnErrorHandler
cn.Open: strSQL = "select * from PRODUCTS_TBL"
rs1.Open strSQL, cn
With ThisWorkbook.Sheets(1)
    Set QT = .QueryTables.Add(rs1, .[A1])
End With
QT.Refresh: QT.Delete
rs1.Close: cn.Close
Set cn = Nothing
Exit Sub

CnErrorHandler:
For Each ADOErr In cn.Errors        'Отладчик
    MsgBox "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source, vbCritical
    Debug.Print "№ ошибки " & ADOErr.Number & Chr(10) & _
    "Описание: " & ADOErr.Description & Chr(10) & _
    "Источник: " & ADOErr.Source
    cn.Close
Set cn = Nothing
Next ADOErr
End Sub

Public Sub Перенос2()
Dim m As Range
Dim m1 As Variant
Dim i As Long, j As Long
Dim a As String, b As String, s As String

With ThisWorkbook.Sheets("1.БД_анализ")
   Set m = .Range(.Cells(2, 1).Address, .Cells(Application.WorksheetFunction.CountA(.Columns(2)), 2).Address)
       m1 = m.Value
End With
With ThisWorkbook.Sheets("5.Код_дата")
    .Cells.ClearContents
    For i = 1 To m.Rows.Count
        a = m1(i, 1)
        b = m1(i, 2)
        For j = 1 To Len(b)
            If Mid(b, j, 1) = ";" Then
                .Cells(i, 1).Value = a
                .Cells(i, 2).Value = s
                s = ""
            Else
                s = s + Mid(b, j, 1)
            End If
        Next j
    Next i
End With
End Sub

    Sheets("5.Код_дата").Select
    Cells().Select
    Selection.ClearContents
    Cells(1, 1).Select

With ThisWorkbook.Sheets("5.Код_дата")
    .Cells.ClearContents
End with

Sub GetGroupedItems()
Dim pt As Excel.PivotTable
Dim ptField As Excel.PivotField
Dim ptItem As Excel.PivotItem
Dim ptChildItem As Excel.PivotItem

Set pt = ActiveSheet.PivotTables(1)
For Each ptField In pt.PivotFields
    For Each ptItem In ptField.PivotItems
        If ptItem.ChildItems.Count > 0 Then
            Debug.Print ptItem.Name
            For Each ptChildItem In ptItem.ChildItems
                Debug.Print ptChildItem.Name
            Next ptChildItem
        End If
    Next ptItem
Next ptField
End Sub

Option Explicit
Sub Cross_DATA()
Dim i As Long, ii As Long, j As Long, jj As Long
Dim wsR As Worksheet, ws As Worksheet
Dim rng1 As Range, rng2 As Range, rng3 As Range
Dim s
On Error Resume Next
Set rng1 = Application.InputBox("Выделите массив ВЕРТИКАЛЬНЫЙ!", Type:=8)
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
If rng1 Is Nothing Then End
Set rng2 = Application.InputBox("Выделите массив ГОРИЗОНТАЛЬНЫЙ!", Type:=8)
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
If rng2 Is Nothing Then End
Set rng3 = Application.InputBox("Выделите массив ДАННЫХ!", Type:=8)
'If rng3 Is Nothing Then End
On Error GoTo 0
'If (rng1.Rows.Count > 1 And rng1.Columns.Count > 1) And (rng2.Rows.Count > 1 And rng2.Columns.Count > 1) Then MsgBox "Двумерные массивы невозможно размножить!", vbCritical, "Error": End
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "Харабардашка" Then ws.Delete: Exit For
Next ws
Application.DisplayAlerts = True
Set wsR = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)): wsR.Name = "Харабардашка"
For i = 1 To rng1.Rows.Count  'Вертикаль Массив1
    For ii = 1 To rng1.Columns.Count
        If rng1(i, ii) <> "" Then
            With wsR
                .Cells(.Cells(.Rows.Count, ii).End(xlUp).Row + 1, ii).Value = rng1(i, ii)
            End With
        End If
    Next ii
    With wsR
        For j = 1 To rng2.Rows.Count   'Горизонт Массив2
            For jj = 1 To rng2.Columns.Count
                If rng2(j) <> "" Then
                    .Cells(.Cells(.Rows.Count, rng1.Columns.Count + j).End(xlUp).Row + 1, rng1.Columns.Count + j).Value = rng2(j, jj)
                End If
            Next jj
        Next j
    End With
    'Протянуть
    With wsR
        For j = .Cells(.Rows.Count, 1).End(xlUp).Row To .Cells(.Rows.Count, rng1.Columns.Count + 1).End(xlUp).Row - 1
            .Range(.Cells(j + 1, 1), .Cells(j + 1, rng1.Columns.Count)).Value = .Range(.Cells(j, 1), .Cells(j, rng1.Columns.Count)).Value
        Next j
        If Not rng3 Is Nothing Then
            For jj = 1 To rng3.Columns.Count
                .Cells(.Cells(.Rows.Count, rng2.Rows.Count + rng1.Columns.Count + 1).End(xlUp).Row + 1, .Cells(.Cells(.Rows.Count, rng2.Rows.Count + rng1.Columns.Count + 1).End(xlUp).Row + 1, .Columns.Count).End(xlToLeft).Column + 1).Value = rng3(i, jj)
            Next jj
        End If
    End With
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub