[IMG]https://ibb.co/yVP5g54[/IMG]
'создаем строку запроса
    For li = LBound(avSheets) To UBound(avSheets)
 
           sQuery = "SELECT " & "SELECT COL_NAME(OBJECT_ID(" & avSheets(li) & " ), 1)" & " FROM [" & avSheets(li) & "$]"
                                                        
             
      Next li
    'сначала создаем подключение к временному файлу
    'это поможет избежать ошибок подключения к открытому файлу
    sCon = _
    "ODBC;DSN=Excel Files;DBQ=" & sTmpFileName & ";" & _
           "DefaultDir=" & sPath & ";DriverId=790;" & _
           "MaxBufferSize=2048;PageTimeout=5"

    Set oPTCache = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)
    With oPTCache
        .Connection = sCon
        .CommandType = xlCmdSql
        .CommandText = sQuery
        Set oPT = .CreatePivotTable(rRes(3, 1))
    End With

    sQuery = "SELECT " & "SELECT COL_NAME(OBJECT_ID(" & avSheets(li) & " ), 1)" & " FROM [" & avSheets(li) & "$]"

 sQuery = "SELECT " & "SELECT COL_NAME(OBJECT_ID(" & avSheets(li) & " ), 1)" & " FROM [" & avSheets(li) & "$]"

Set rg = ThisWorkbook.Sheets(Element).UsedRange.Columns(1)

  Sheets("настройка_отчета").Range("d9:d" & UBound(IndeksArray) + 9).Value = IndeksArray  
    ' Sheets("настройка_отчета").Range("C9:C" & UBound(IndeksArray) + 9).Value = DataArray1
    For Counter = 1 To UBound(DataArray1)
     Sheets("настройка_отчета").Range("C9:C" & [Counter] + 9).Value = CVar(DataArray1(Counter))    
    Next Counter

Function CombineArrays(Arr1 As Variant, Arr2 As Variant) As Variant
  
    If (Not IsArray(Arr1)) And IsArray(Arr2) Then CombineArrays = Arr2: Exit Function
    If (Not IsArray(Arr2)) And IsArray(Arr1) Then CombineArrays = Arr1: Exit Function
   
    If (Not IsArray(Arr2)) And (Not IsArray(Arr1)) Then
        Debug.Print "??????: ??? ?????????? ???????? ?? ???????? ?????????!"
        CombineArrays = Null: Exit Function
    End If

    On Error Resume Next: Err.Clear
 
    If (LBound(Arr1, 2) <> LBound(Arr2, 2)) Or (UBound(Arr1, 2) <> UBound(Arr2, 2)) Then
        Debug.Print "??????: ??????????? ???????? (?? ??????) ?? ?????????"
        CombineArrays = Null: Exit Function
    End If
    If Err.Number = 9 Then
        Debug.Print "??????: ???? ?? ???????? ?? ???????? ?????????!"
        CombineArrays = Null: Exit Function
    End If

    ReDim arr(1 To UBound(Arr1, 1) + UBound(Arr2, 1), LBound(Arr1, 2) To UBound(Arr1, 2))
 
    For i = 1 To UBound(Arr1, 1)
        For j = LBound(Arr1, 2) To UBound(Arr1, 2)
            arr(i, j) = Arr1(i, j)
        Next
    Next
 
    For i = 1 To UBound(Arr2, 1)
        For j = LBound(Arr2, 2) To UBound(Arr2, 2)
            arr(i + UBound(Arr1, 1), j) = Arr2(i, j)
        Next
    Next
    CombineArrays = arr    ' ?????????? ???????????? ??????
End Function

Function CombineArrays2(Arr1 As Variant, Arr2 As Variant) As Variant
    If (Not IsArray(Arr1)) And IsArray(Arr2) Then CombineArrays2 = Arr2: Exit Function
    If (Not IsArray(Arr2)) And IsArray(Arr1) Then CombineArrays2 = Arr1: Exit Function
    ' если оба параметра функции не являются массивами
    If (Not IsArray(Arr2)) And (Not IsArray(Arr1)) Then
        Debug.Print "ОШИБКА: Оба переданных значения не являются массивами!"
        CombineArrays2 = Null: Exit Function
    End If
 
    ' проверяем совпадение размерностей массивов Arr1 и Arr2
    On Error Resume Next: Err.Clear
    ReDim arr(1 To UBound(Arr1) + UBound(Arr2))
 
    For i = 1 To UBound(Arr1, 1)
            arr(i) = Arr1(i)
    Next
 
    For i = 1 To UBound(Arr2, 1)    
            arr(i + UBound(Arr1)) = Arr2(i)
    Next
    CombineArrays2 = arr    ' возвращаем объединённый массив
End Function

Sub CreateTableM()
Dim arrRecords() As Variant
Dim aa As Variant
Dim Element As Variant
Dim rg As Range
Dim rg2 As Range
Dim rg3 As Range
Dim objRange As Range

Dim IndeksArray As Variant
Dim DataArray1 As Variant
Dim DataArray2 As Variant
Dim k As Integer
Dim ttt As Integer
Dim cl As New Collection, x

k = 0
Dim arrWsNames
arrWsNames = Array("Жовтень2021", "Жовтень2020", "Жовтень2019")
ttt = 1
ReDim DataArray2(ttt)
ReDim DataArray1(ttt)
   For Each Element In arrWsNames
     With Line
        ttt = SLastRow(Element)
     Set rg = ThisWorkbook.Sheets(Element).UsedRange.Columns(1)
     Set rg2 = ThisWorkbook.Sheets(Element).UsedRange.Columns(27)
      
        ttt = UBound(ThisWorkbook.Sheets(Element).UsedRange.Columns(1).Value)
        ReDim DataArray2(ttt)
        For i = 1 To ttt
          DataArray2(i) = Element
        Next i

         Set objRange = Union(rg, rg2)
          ОбъединённыйМассив12 = CombineArrays(IndeksArray, objRange)
        
          IndeksArray = ОбъединённыйМассив12
          ОбъединённыйМассив11 = CombineArrays2(DataArray1, DataArray2)
          DataArray1 = ОбъединённыйМассив11

        If SLastCol(Element) = 75 Then
          '  aa = rF.Value2
  
        ElseIf SLastCol(Element) = 80 Then
           ' aa = rF.Value2

        ElseIf SLastCol(Element) = 89 Then
        
           ' aa = rF.Value2
        
        End If
        k = SLastRow(Element)
        
       End With  
     Next
 'обїединение одномерных массивов в многомерный
 ReDim Preserve arrRecords(1 To ttt, 1 To 42)

     Sheets("настройка_отчета").Range("d9:d" & UBound(IndeksArray) + 9).Value = IndeksArray
     
    ' Sheets("настройка_отчета").Range("C9:C" & UBound(IndeksArray) + 9).Value = DataArray1
    For Counter = 1 To UBound(DataArray1)
     Sheets("настройка_отчета").Range("C9:C" & [Counter] + 9).Value = CVar(DataArray1(Counter))
       
    Next Counter
End Sub

.Fill.ForeColor.RGB = vbYellow

Dim list As Worksheet
Dim NorthAmerica As Shape
Dim SouthAmerica As Shape
Dim Europe As Shape
Dim Asia As Shape
Dim Africa As Shape
Dim Australia As Shape
Dim tovar1 As Long
Dim tovar2 As Long
Dim tovar3 As Long
tovar1 = Range("B1").Interior.Color
tovar2 = Range("C1").Interior.Color
tovar3 = Range("D1").Interior.Color

Dim a() As Variant
a = Array(tovar1, tovar2, tovar3)

Set list = Sheets("ВИЗУАЛИЗАЦИЯ")
Set Kodumska_ob = list.Shapes("Kodumska")
With Kodumska_ob
        '?????? ?????? ? ?????? ??????
        .Height = 150
        .Width = 100
        '?????? ???? ??????
        .Fill.ForeColor.RGB = vbYellow
        '???????????? ?????? ????? ?? 40 ????????
        .Rotation = -40
    End With

Option Explicit
Public Function SheetList() As String()
 
Dim sheet As Worksheet
Dim n As Integer
Dim i As Integer
Dim arr() As String
Dim cell As Range
 
i = 1
 
n = 0
 
With ActiveWorkbook
 
For Each sheet In ActiveWorkbook.Worksheets
 
 'Set cell = Worksheets(1).Cells(sheet.Index, 1)
 
'MsgBox (sheet.Name)
 
If ((sheet.Name <> "Ñïðàâî÷íèê") And (sheet.Name <> "îò÷åò") And (sheet.Name <> "Ñâîä")) Then
 n = n + 1
End If
 
Next
 
End With
 
ReDim arr(1 To n)
 
   
With ActiveWorkbook
 
For Each sheet In ActiveWorkbook.Worksheets
 
Set cell = Worksheets(1).Cells(sheet.Index, 1)
 
  'cell.Formula = sheet.Name
 
 'MsgBox (sheet.Name)
 
 If ((sheet.Name <> "Ñïðàâî÷íèê") And (sheet.Name <> "îò÷åò") And (sheet.Name <> "Ñâîä")) Then
 
   arr(i) = sheet.Name
 
   i = i + 1
 
 End If
 
Next
 
 End With
  
SheetList = arr()
  
 
End Function
Sub PTFromMultipleSheets()
    Dim oPTCache As PivotCache, oPT As PivotTable
    Dim sPath As String, sWbFulName As String, sTmpFileName As String
    Dim avSheets() As String
    Dim sCols As String, sQuery As String, sCon As String
    Dim rRes As Range
    Dim li As Long

    sPath = ThisWorkbook.Path
    sWbFulName = ThisWorkbook.FullName
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sTmpFileName = sPath & "TempWbForDB_" & Format(Now, "yyyymmddhhmmss") & ".xls"
    'ñþäà ìîæíî äîáàâèòü åùå ëèñòû
    'òàáëèöû íà ëèñòàõ äîëæíû èìåòü îäèíàêîâîå êîë-âî ñòîëáöîâ
    'ñòîëáöû ìîãóò áûòü â ðàçíîì ïîðÿäêå, íî èìåòü îäèíàêîâûå çàãîëîâêè
    avSheets = SheetList()
    'íèæå ïåðå÷èñëÿþòñÿ çàãîëîâêè ñòîëáöîâ, íà îñíîâå êîòîðûõ ñòðîèòñÿ ñâîäíàÿ
    '÷åðåç çàïÿòóþ â êâàäðàòíûõ ñêîáêàõ
      sCols = "[Îáúåêò],[Êîíòðàãåíò],[ÑóììàÄîêóìåíòà]"
    'sCols = "*" ' - åñëè íåîáõîäèìî âêëþ÷èòü âñå ñòîëáöû
    'ïðè ýòîì øàïêà íà âñåõ ëèñòàõ äîëæíà áûòü ïîëíîñòüþ îäèíàêîâàÿ
    'äàííûå áóäóò â òîì ïîðÿäêå, â êîòîðîì ðàñïîëîæåíû ñòîëáöû
    
    Application.ScreenUpdating = False
    If Val(Application.Version) > 11 Then DelCon
    Set rRes = ThisWorkbook.Sheets(1).Cells
    rRes.Clear
    ThisWorkbook.Worksheets(avSheets).Copy
    With ActiveWorkbook
        .SaveAs sTmpFileName
        .Close
    End With
    'ñîçäàåì ñòðîêó çàïðîñà
    For li = LBound(avSheets) To UBound(avSheets)
        If li > 0 Then
            sQuery = sQuery & " UNION SELECT " & sCols & " FROM [" & avSheets(li) & "$]"
        Else
            sQuery = "SELECT " & sCols & " FROM [" & avSheets(li) & "$]"
        End If
    Next li
    'ñíà÷àëà ñîçäàåì ïîäêëþ÷åíèå ê âðåìåííîìó ôàéëó
    'ýòî ïîìîæåò èçáåæàòü îøèáîê ïîäêëþ÷åíèÿ ê îòêðûòîìó ôàéëó
    sCon = _
    "ODBC;DSN=Excel Files;DBQ=" & sTmpFileName & ";" & _
           "DefaultDir=" & sPath & ";DriverId=790;" & _
           "MaxBufferSize=2048;PageTimeout=5"

    Set oPTCache = ThisWorkbook.PivotCaches.Add(SourceType:=xlExternal)
    With oPTCache
        .Connection = sCon
        .CommandType = xlCmdSql
        .CommandText = sQuery
        Set oPT = .CreatePivotTable(rRes(3, 1))
    End With
    'òåïåðü èçìåíÿåì â çàïðîñå ñâîäíîé ïóòü ê ôàéëó íà òåêóùèé
    sCon = _
    "ODBC;DSN=Excel Files;DBQ=" & sWbFulName & ";" & _
           "DefaultDir=" & sPath & ";DriverId=790;" & _
           "MaxBufferSize=2048;PageTimeout=5"
    ThisWorkbook.PivotCaches(1).Connection = sCon

    With oPT
        'âûñòàâëÿåì ïåðâîíà÷àëüíûå íàñòðîéêè äëÿ ñâîäíîé
        With .PivotFields(1)
            .Orientation = xlRowField
            .Position = 1
        End With
        With .PivotFields(2)
            .Orientation = xlRowField
            .Position = 2
        End With
        .AddDataField .PivotFields("Ñóììà"), "Ñóììà ïî ïîëþ Ñóììà", xlSum
    End With

    'óäàëÿåì âðåìåííûé ôàéë
    Kill sTmpFileName
    Set oPT = Nothing: Set oPTCache = Nothing
    Application.ScreenUpdating = True
End Sub

'---------------------------------------------------------------------------------------
' Procedure : DelCon
' Purpose   : Ïðîöåäóðà óäàëÿåò ïîäêëþ÷åíèÿ
'             Òðåáóåòñÿ òîëüêî äëÿ âåðñèé, âûøå 2003
'---------------------------------------------------------------------------------------
Private Sub DelCon()
    On Error Resume Next: ThisWorkbook.Connections(1).Delete: On Error GoTo 0
End Sub

Sub RefreshCon()
    Dim sCon As String, sPath As String, sWbFulName As String
    sPath = ThisWorkbook.Path
    sWbFulName = ThisWorkbook.FullName
    sCon = _
    "ODBC;DSN=Excel Files;DBQ=" & sWbFulName & ";" & _
           "DefaultDir=" & sPath & ";DriverId=790;" & _
           "MaxBufferSize=2048;PageTimeout=5"
    With ThisWorkbook
        If .PivotCaches.Count > 0 Then .PivotCaches(1).Connection = sCon
    End With
End Sub

СтрокаПодключения="Provider=Microsoft.ACE.OLEDB.16.0;Data Source=G:\11\Кадорр, Б.Арнаутская 26-30.xlsx;Extended Properties=Excel 16.0;";
// создание соединения
Connection=Новый ComObject("ADODB.Connection");
// Подключение
Попытка
Connection.Open(СтрокаПодключения);
Исключение
// Возврат

Сообщить("Ошибка подключения к EXCEL");
Возврат;
КонецПопытки;
сообщить("УСПЕШНО EXCEL"); 

 division =";"

pReg.Pattern = "[" & ":" & division & "]" & "(.*?)" & "[" & division & "$]" & "[^" & division & "]"   'шаблон поиска.

"[" & ":"  & "]" & "(.*?)"& "[" & division & "]"

pReg.Pattern = "^" & "(.*?)" & "^\["

функция 2()

for i=1 to 34
    m = функция1 (mF(i, 16),....)
next i

функция 2( функция1 (mF(i, 16)) )

 Public iArr As New Arr1
 Public imyColumns As Long
 Public imyRows As Long

Public iArr() As Variant 
 Public imyColumns As Long
 Public imyRows As Long

 Dim Arr1() As Variant

Sub Example()
    Dim Large_Array As New Large_Array
    Dim Arr()  As New MyArr
    Large_Array.Path_Import_file = "G:\ÐÀÇÐÀÁÎÒÊÀ_2\äàííî" & "\"
    Large_Array.Import_file = "exim_ua_2015_1-8_ðûá.xls"
    Large_Array.Sheet_Import_file = "exim_ua_2015_1_8_ðûá"
    Arr().iArr = Large_Array.ToArray().iArr
       
End Sub

.....
Public Function ToArray() As MyArr
    Dim Data() As Variant
    Dim Arr() As New Arr1
    Dim Column As Long
    Dim Row As Long
    Dim t As MyArr
............................
    t.iArr = Arr
    t.imyColumns = UBound(Data, 2)
    t.imyRows = UBound(Data, 1)
   

Public Function ToArray() As MyArr
    Dim Data() As Variant
    Dim Arr() As Variant
    Dim Column As Long
    Dim Row As Long
    
    ADO.DataSource = Path_Import_file & Import_file    ' ïîëíûé ïóòü ê êíèãå
    ADO.Query ("SELECT * FROM [" & Sheet_Import_file & "$]")
    ToArray = ADO.ToArray()
End Function