Function DataTransfer(Way1 As String)
Dim Arr1()
Dim i As Long, j As Integer
Dim isql As String
Dim con As Object
Dim rs As Object
Dim tableName As String


Set con = CreateObject("ADODB.Connection") ' подключение к книге Excel
con.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & Way1 & """;Extended Properties=""Excel 12.0;HDR=Yes"";"
con.Open

Set rs = con.OpenSchema(adSchemaTables)

tableName = rs!TABLE_NAME  ' получил имя листа в книге Excel
rs.Close

Set rs = CreateObject("ADODB.Recordset")

isql = "SELECT * FROM [" & tableName & "] WHERE F1"  ' запрос к листу книги Excel
rs.Open isql, con

Arr1() = rs.GetRows 'передача записей на листе книги в массив

rs.Close
con.Close

end function

List.range("A1").resize(UBound(ArrSborList),UBound(ArrSborList, 2))=ArrSborList

For i = 1 To UBound(ArrSborList, 2)
        For n = 1 To UBound(ArrSborList, 1)
            List.Cells(i, n).Value = ArrSborList(n, i)
        Next n
Next i

Sub Podschet()
    Set List = ThisWorkbook.ActiveSheet
    
    For k = 4 To List.UsedRange.Rows.Count - 1
        If List.Cells(k, 10).Value <> "" Then
            List.Cells(k, 11) = Round(List.Cells(k, 7).Value / List.Cells(k, 3).Value * 100)
            List.Cells(k, 12) = List.Cells(k, 8).Value
        End If
        
        If List.Cells(k, 5).Value <> "" Then List.Cells(k, 13) = List.Cells(k, 5) - List.Cells(k, 8)
    Next k
End Sub

ReDim ArrSbor (1 to 1, 1 to 1) as variant
x=1
y=1

Do while List.Cells (x,1) <> ""
     ReDim Preserve ArrSbor (1 to x, 1 to y) 
                  For y=1 to 10
                       ArrSbor (x,y)=List.Cells (x,y)
                  Next y  
 x=x+1  
Loop