wdSel.InsertFile Filename:=fPath, ConfirmConversions:=False

' Указываем путь к папке с Excel-файлами
folderPath = "C:\Ваша_папка" ' Измените на нужный путь

' Создаем объекты
Set objExcel = CreateObject("Excel.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folderPath)

' Настройки Excel
objExcel.Visible = False
objExcel.ScreenUpdating = False

' Проходим по всем файлам в папке
For Each objFile In objFolder.Files
    ' Проверяем, является ли файл Excel-файлом
    If LCase(objFSO.GetExtensionName(objFile.Name)) = "xls" Or LCase(objFSO.GetExtensionName(objFile.Name)) = "xlsx" Then
        ' Открываем файл
        Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
        
        ' Применяем Autofit к активному листу
        On Error Resume Next
        objWorkbook.ActiveSheet.UsedRange.EntireRow.AutoFit
        On Error GoTo 0
        
        ' Печатаем файл
        objWorkbook.PrintOut
        
        ' Закрываем файл без сохранения изменений
        objWorkbook.Close False
    End If
Next

' Закрываем Excel
objExcel.Quit

' Освобождаем объекты
Set objWorkbook = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
Set objExcel = Nothing

' Проверяем, были ли переданы аргументы (файлы)
If WScript.Arguments.Count = 0 Then
    MsgBox "Перетащите Excel-файл(ы) на этот скрипт."
    WScript.Quit
End If

' Создаем объекты Excel и файловой системы
Set objExcel = CreateObject("Excel.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Настройки Excel
objExcel.Visible = False
objExcel.ScreenUpdating = False

' Обрабатываем каждый переданный файл
For Each strFile In WScript.Arguments
    ' Проверяем, является ли файл Excel-файлом
    If LCase(objFSO.GetExtensionName(strFile)) = "xls" Or LCase(objFSO.GetExtensionName(strFile)) = "xlsx" Then
        ' Открываем файл
        On Error Resume Next
        Set objWorkbook = objExcel.Workbooks.Open(strFile)
        If Err.Number = 0 Then
            ' Применяем Autofit к активному листу
            On Error Resume Next
            objWorkbook.ActiveSheet.UsedRange.EntireRow.AutoFit
            On Error GoTo 0
            
            ' Печатаем файл
            objWorkbook.PrintOut
            
            ' Закрываем файл без сохранения изменений
            objWorkbook.Close False
        Else
            MsgBox "Не удалось открыть файл: " & strFile
        End If
        On Error GoTo 0
    Else
        MsgBox "Файл не является Excel-файлом: " & strFile
    End If
Next

' Закрываем Excel
objExcel.Quit

' Освобождаем объекты
Set objWorkbook = Nothing
Set objFSO = Nothing
Set objExcel = Nothing

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"