Sub Get_All_File_from_Folder()
Dim sFolder As String, sFiles As String
Dim wb As Workbook
Dim fso As Object, foldr As Object, foldr1 As Object

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FolderExists("C:\УЗК") Or fso.FolderExists("C:\УЗК_ОБЩ") Then

Call RemovingTempFiles

Path0 = "C:\УЗК"
Path1 = "C:\УЗК_ОБЩ"
fso.CreateFolder Path0
fso.CreateFolder Path1

Else

Path0 = "C:\УЗК"
Path1 = "C:\УЗК_ОБЩ"
fso.CreateFolder Path0
fso.CreateFolder Path1

End If

Set foldr = fso.getfolder(Path0)
Set foldr1 = fso.getfolder(Path1)

'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)

Application.ScreenUpdating = False
sFiles = Dir(sFolder & "Зак*.xls*")
Do While sFiles <> ""
'открываем книгу
Set wb = Application.Workbooks.Open(sFolder & sFiles)
'действия с файлом
FileName = Path0 & "\" & wb.Sheets("УК").Cells(3, 12) & "-" & wb.Sheets("УК").Cells(3, 13) _
& "-" & wb.Sheets("УК").Cells(3, 14) & ".xlsx"

Err.Clear: wb.Sheets("УК").Copy: DoEvents

arr = wb.Sheets("УК").UsedRange.Value

ActiveSheet.Buttons.Delete
Range("A1:R25").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("T7:U15").Select
Selection.ClearContents

Range("J27:P33").Select
Selection.EntireRow.Delete

Range("A1").Select

If Err Then Exit Sub

If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName, xlOpenXMLWorkbook
ActiveWorkbook.Close True

End If

'Закрываем книгу с сохранением изменений
wb.Close False 'если поставить False - книга будет закрыта без сохранения
sFiles = Dir
Loop

Call MergingFiles

Application.ScreenUpdating = True

End Sub

Sub MergingFiles()
' Собираем все листы в новую книгу с именем ТП

Application.DisplayAlerts = False

Dim CurFile As String
Dim DestWB As Workbook
Dim ws As Object 'Рабочие листы могут быть произвольного типа.

Const DirLoc As String = "C:\УЗК\" 'Местоположение исходных файлов.
Const DirLoc1 As String = "C:\УЗК_ОБЩ\" 'Местоположение конечного файла.

Application.ScreenUpdating = False

Set DestWB = Workbooks.Add(xlWorksheet)
CurFile = Dir(DirLoc & "*.xlsx")

Do While CurFile <> vbNullString

Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(FileName:=DirLoc & CurFile, _
ReadOnly:=True)
CurFile = Left(Left(CurFile, Len(CurFile) - 4), 29)

'Получение базового имени
'рабочего листа путем отсечения
'последних 4-х символов имени
'исходного файла (".xlsx").

For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)

If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If

Next

OrigWB.Close SaveChanges:=False
CurFile = Dir

Loop

FinalFileName = DirLoc1 & "Общ_УЗК" & ".xlsx"

ActiveWorkbook.SaveAs FileName:=FinalFileName, _
FileFormat:=xlWorkbookDefault

Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set DestWB = Nothing

'Application.DisplayAlerts = True

End Sub

Sub RemovingTempFiles()
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

fso.DeleteFolder ("C:\УЗК")
fso.DeleteFolder ("C:\УЗК_ОБЩ")

End Sub