Set conn = CreateObject("ADODB.Connection")
BDfile="\\БД\Данные.accdb"
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & BDfile & ";"
Table_Name =1076
' Создание новой таблицы
strSQL = "CREATE TABLE [" & Table_Name & "] ([Компонент] TEXT, [Детектор] TEXT, [Площадь] DOUBLE)"
conn.Execute strSQL
    
    ' Вставка данных из Excel
xlFile = ThisWorkbook.path & "\" & ThisWorkbook.Name
strSQL = "INSERT INTO [" & Table_Name & "] SELECT * FROM [Данные$] IN '" & xlFile & "' [Excel 12.0; Xml; HDR=YES;]"
conn.Execute strSQL

.copy
...
[A1].Select

Set coll = JsonConverter.ParseJson(oHTTP.ResponseText)

Sub Найти_Последнюю_Ячейку()
Dim iLastRow As Long
with sheets("HiddenList") ' Нужное имя впишите сами
    iLastRow = .Cells(Rows.Count, 44).End(xlUp).Row
    debug.print "Значение в последней ячейке " & .Cells(iLastRow + 1, 1).value
end with
End Sub

Sub test1()
    Dim n As Integer
    Dim t As Double
    Dim log As String
    Dim calcMode As XlCalculation
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    calcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    With ActiveSheet
        .Columns(2).Clear
        t = Timer

        For n = 1 To 100
            .Cells(n, 1).Copy .Cells(n, 2)
        Next n

        log = "test1: " & Timer - t
        .Columns(2).Clear
        t = Timer

        For n = 1 To 100
            .Cells(n, 1).Copy
            .Cells(n, 2).PasteSpecial
        Next n

        log = log & vbLf & "test2: " & Timer - t
        .Columns(2).Clear
        t = Timer

        For n = 1 To 100
            .Cells(n, 2) = .Cells(n, 1)
            .Cells(n, 1).Copy
            .Cells(n, 2).PasteSpecial xlPasteFormats
        Next n

        log = log & vbLf & "test3: " & Timer - t
        .Columns(2).Clear
        t = Timer

        For n = 1 To 100
            .Cells(n, 2) = .Cells(n, 1)
            .Cells(n, 2).NumberFormat = "0.000"
        Next n

        log = log & vbLf & "test4: " & Timer - t
        'MsgBox log
        .Cells(1, 8) = log
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = calcMode

End Sub

Public Sub Change()
    Dim pItem As Object, pSeries As Object, i As Long
    If TypeOf Selection Is DrawingObjects Then
        For Each pItem In Selection
            debug.print pItem.Name
            For i = 1 To pItem.Chart.SeriesCollection.Count
                debug.print pItem.Chart.SeriesCollection(i).Formula 
            Next
        Next
    End If
End Sub

Filename = Format(Now, "DD-MM-YYYY-HH-NN") & ".xlsx"

Filename = Range("A1").value & ".xlsx"