Sub УдалениеМакросовИзКнигиEXCEL()
    On Error Resume Next: Err.Clear
    
    ' макрос работает только в Excel 2007 (и более новых версиях)
   If Val(Application.Version) < 12 Then Exit Sub

    ' получаем полный путь к текущему файлу Excel
  oldName$ = ActiveWorkbook.FullName

    ' выход, если файл уже в нужном формате (XLSX)
  If UCase$(oldName$) Like "*.XLSX" Then Exit Sub

    ' формируем новое имя файла (меняем расширение)
  newName$ = Left(oldName$, InStrRev(oldName$, ".") & "xlsx"

    ' сохраняем файл под новым именем в формате XLSX
  ActiveWorkbook.SaveAs newName$, xlExcel12

    ' удаляем прежний файл (в старом формате)
  If Err = 0 Then Kill oldName$
End Sub

Sub union()
Dim name_aps As String

wizzardname = Excel.ActiveWorkbook.Name
Application.ScreenUpdating = True
  vfile = Application.GetOpenFilename("Files  (*.xls; *.xlsx), *.xls; *.xlsx", , ""
  
    If vfile = False Then
        End
    End If
    
name_of_file = Dir(vfile, 7)

Set nof = Workbooks.Open(vfile)

time1 = Now()

If name_of_file Like "*.xls" Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=vfile & "x", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Kill vfile
Application.DisplayAlerts = True
nof.Close
Workbooks.Open (vfile & "x"
End If


For i = 2 To ActiveWorkbook.Sheets.Count
Sheets(i).Select
Range("A1", ActiveCell.SpecialCells(xlLastCell)).Copy
Sheets(1).Select
Cells(Sheets(1).UsedRange.Rows.Count, 1).Select
ActiveCell.Offset(1, 0).Range("A1".PasteSpecial
Next

Application.DisplayAlerts = False
 For i = Sheets.Count To 2 Step -1
  Sheets(i).Delete
 Next
Application.DisplayAlerts = True

Application.ScreenUpdating = True

ActiveWorkbook.Save
ActiveWindow.Close
End Sub

   Sub CombineWorkbooks()
       Dim FilesToOpen
       Dim x As Integer
    
       Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
        
       'вызываем диалог выбора файлов для импорта
       FilesToOpen = Application.GetOpenFilename _
         (FileFilter:="All files (*.*), *.*", _
         MultiSelect:=True, Title:="Files to Merge")
    
       If TypeName(FilesToOpen) = "Boolean" Then
           MsgBox "Не выбрано ни одного файла!"
           Exit Sub
       End If
        
       'проходим по всем выбранным файлам
       x = 1
       While x <= UBound(FilesToOpen)
           Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
           Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
           importWB.Close savechanges:=False
           x = x + 1
       Wend
    
       Application.ScreenUpdating = True
   End Sub

   Sub CombineWorkbooks()
       Dim FilesToOpen
       Dim x As Integer
    
       Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
        
       'открываем нужные файлы
       FilesToOpen = ("C:\Data_Base\Постач_30.xl*" & "C:\Data_Base\ХТ_30.xl*" & "C:\Data_Base\ХТ_ім_30.xl*" & "C:\Data_Base\ВХТ_30.xl*" & "C:\Data_Base\ВХТ_ім_30.xl*")
    
       If TypeName(FilesToOpen) = "Boolean" Then
           MsgBox "Не выбрано ни одного файла!"
           Exit Sub
       End If
        
       'проходим по всем выбранным файлам
       x = 1
       While x <= UBound(FilesToOpen)
           Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
           Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
           importWB.Close savechanges:=False
           x = x + 1
       Wend
    
       Application.ScreenUpdating = True
   End Sub