Sub UnionBooks()

Dim myPath As String, myName As String, ws As Worksheet, wb As Workbook, c As Long
Application.ScreenUpdating = False: Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Укажите рабочую папку"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
myPath = .SelectedItems(1) & "\"
End With

myName = Dir(myPath & "*.xls", vbNormal + vbArchive)
Do While myName <> ""
If myName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(Filename:=myPath & myName, AddToMRU:=False)
For Each ws In wb.Worksheets
On Error Resume Next
ThisWorkbook.Sheets.Add.Name = ws.Name
If Err = 0 Then
ws.Cells.Copy ThisWorkbook.ActiveSheet.[A1]
Else
ThisWorkbook.ActiveSheet.Delete
With ThisWorkbook.Sheets(ws.Name)
c = .UsedRange.Column + .UsedRange.Columns.Count + 1
ws.UsedRange.Copy .Cells(1, c)
ws.UsedRange.Copy: .Cells(1, c).PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
End With
On Error GoTo 0
End If
Next
End If
wb.Close SaveChanges:=False: myName = Dir
Loop
If ThisWorkbook.Sheets.Count > 1 Then ThisWorkbook.Sheets(Sheets.Count).Delete

End Sub