Sub Объединение()

    Dim i As Integer
    Dim Sel As Workbook, Wb As Workbook
    
    Application.DisplayAlerts = False
    
    MsgBox prompt:="Откройте файлы для объединения"
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
        If .SelectedItems.Count > 0 Then
            Workbooks.Add
            Set Wb = ActiveWorkbook
            Do
                On Error Resume Next
                ActiveSheet.Delete
            Loop While Err.Number = 0
            For i = 1 To .SelectedItems.Count
                If InStr(1, .SelectedItems(i), ".xls", vbTextCompare) > 0 Then
                    Workbooks.Open Filename:=.SelectedItems(i)
                    Set Sel = ActiveWorkbook
                    Wb.Activate
                    Worksheets.Add after:=Worksheets(Sheets.Count)
                    On Error Resume Next
                    ActiveSheet.Name = Left(Sel.Name, InStr(1, Sel.Name, ".", vbTextCompare) - 1)
                    If Err.Number <> 0 Then ActiveSheet.Name = Left(Sel.Name, InStr(1, Sel.Name, ".", vbTextCompare) - 1) & i
                    Sel.Worksheets(1).Cells.Copy Destination:=Cells
                    Sel.Close
                End If
            Next i
            If Sheets.Count > 1 Then
                Worksheets(1).Delete
                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\!!! Результат.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            End If
            ActiveWorkbook.Close
        End If
    End With
    
    Application.DisplayAlerts = True

End Sub