Склеить таблицы в книге расположив по вертикали.

[MaxxVer]

Всем привет.

У меня уже есть макрос который склеивает таблицы в книге (по разным листам), располагая из справа друг относительно друга. Необходимо изменить макрос так чтобы он располагал их по вертикали (друг под другом).

Макрос:

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

Const DirLoc As String = "\\fs01-prm-vbi1\Users$\MVerhovcev\Excel\объеди нение" 'Местоположение исходных файлов.
Application.ScreenUpdating = False
Set DestWB = Workbooks.Add(xlWorksheet)
CurFile = Dir(DirLoc & "*.xls")

Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
CurFile = Left(Left(CurFile, Len(CurFile) - 10), 40)

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

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

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

End Sub

[SAS888]

макрос который склеивает таблицы в книге (по разным листам), располагая из справа друг относительно друга.

Ваш макрос лишь копирует листы из книги в книгу. Не вижу, чтобы что-то с чем-то "склеивалось" внутри какого-либо листа.
Или я не понял вопрос...

[MaxxVer]

Похоже не тот макрос выложил, уже запамятовал какой из них что делает...
Суть в том чтобы склеить листы в книге по вертикали.

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(msoFileDialo gFolderPicker)
.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).D elete

End Sub

[SAS888]

Попробуйте вместо Вашего цикла

For Each ws In wb.Worksheets
    '...
    '...
Next

использовать

For Each ws In wb.Worksheets
    With ThisWorkbook.ActiveSheet
        ws.UsedRange.Copy .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
    End With
Next

Данные всех книг всех листов будут скопированы на активный лист книги, содержащей этот код.
Если нужно копировать на другие листы, то вместо With ThisWorkbook.ActiveSheet используйте ссылку на требуемый лист. Например:

With ThisWorkbook.Sheets(ws.Name)

естественно, предварительно проверив, существует ли такой лист.

[MaxxVer]

Спасибо огромное. Сработало.