Dim xla
Sub RunProcessingXlk()
'Используем ФСО для возврата всех файлов в выбранной папке
'идем циклом по файлу, получаем его имя и далее работаем с рабочей книгой с этим именем
Dim fso, fld, f1, fc, s
Dim FolderSpec
Dim d1, d2
Dim lng_FileCount As Long
lng_FileCount = 0
d1 = Now
'CHANGE FOLDER===========================================================================
FolderSpec = "d:\docs\КировгрОтчеты\ТестОбрДолжн\"
'========================================================================================
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(FolderSpec)
Set fc = fld.Files
For Each f1 In fc
    If lng_FileCount > 0 Then
        Set xla = GetObject(, "Excel.Application")
    Else
        Set xla = New Excel.Application
    End If
    xla.ScreenUpdating = False
    s = f1.Name: lng_FileCount = lng_FileCount + 1
    
        OneXlsWBProcessing s, FolderSpec
   
Next f1
xla.ScreenUpdating = True
Set xla = Nothing
d2 = Now
MsgBox "Ура, ура! Обработка кучи экселек завершена", vbInformation, "satart at " & d1 & " end at " & d2
End Sub

Sub OneXlsWBProcessing(WBFileName, FolderSpec)
'Обработка единственного эксельного файла
Dim xlw, xls
Dim strStartCell As String, stryyyymm01 As String
strStartCell = "A1"
Set xlw = xla.Workbooks.Open(FolderSpec & WBFileName)
'    xla.Visible = False
Set xls = xlw.ActiveSheet

Dim lng_row_count As Long, lng_col_count As Long
With xls
    .Columns("A:A").Delete Shift:=xlToLeft
    .Rows("1:3").Delete Shift:=xlUp
    .Rows("2:2").Delete Shift:=xlUp
    lng_row_count = .Range(strStartCell).CurrentRegion.Rows.Count
    lng_col_count = .Range(strStartCell).CurrentRegion.Columns.Count
    .Rows(lng_row_count).Delete Shift:=xlUp
    .Cells(1, lng_col_count + 1) = "Расчетный период"
    stryyyymm01 = Left(WBFileName, 6) & "01"
    .Cells(2, lng_col_count + 1).FormulaR1C1 = stryyyymm01
    .Cells(2, lng_col_count + 1).AutoFill Destination:=.Range(.Cells(2, lng_col_count + 1), .Cells(lng_row_count - 1, lng_col_count + 1))
End With
xlw.Names.Add "Data0", xlw.Sheets(1).Range(strStartCell).CurrentRegion
xlw.Close SaveChanges:=True
Set xls = Nothing
Set xlw = Nothing
    
End Sub