|
|
Регистрация Восстановить пароль |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
15.12.2009, 07:31 | #1 |
Форумчанин
Регистрация: 17.03.2009
Сообщений: 226
|
Склеить таблицы в книге расположив по вертикали.
Всем привет.
У меня уже есть макрос который склеивает таблицы в книге (по разным листам), располагая из справа друг относительно друга. Необходимо изменить макрос так чтобы он располагал их по вертикали (друг под другом). Макрос: 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 |
15.12.2009, 07:45 | #2 | |
Старожил
Регистрация: 05.12.2007
Сообщений: 4,180
|
Цитата:
Или я не понял вопрос...
Чем шире угол зрения, тем он тупее.
|
|
15.12.2009, 08:14 | #3 |
Форумчанин
Регистрация: 17.03.2009
Сообщений: 226
|
Похоже не тот макрос выложил, уже запамятовал какой из них что делает...
Суть в том чтобы склеить листы в книге по вертикали. 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 |
15.12.2009, 09:00 | #4 |
Старожил
Регистрация: 05.12.2007
Сообщений: 4,180
|
Попробуйте вместо Вашего цикла
Код:
Код:
Если нужно копировать на другие листы, то вместо With ThisWorkbook.ActiveSheet используйте ссылку на требуемый лист. Например: Код:
Чем шире угол зрения, тем он тупее.
Последний раз редактировалось SAS888; 15.12.2009 в 09:06. |
15.12.2009, 09:19 | #5 |
Форумчанин
Регистрация: 17.03.2009
Сообщений: 226
|
Спасибо огромное. Сработало.
|
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
склеить 2 массива по порядку с помощью формулы | MaxxVer | Microsoft Office Excel | 5 | 21.06.2010 17:29 |
Выравнивание текста по вертикали | bowa | HTML и CSS | 8 | 20.09.2009 20:34 |
Данные из двух полей исх. таблицы в одно поле сводной таблицы | Strelec79 | Microsoft Office Excel | 2 | 02.08.2009 13:59 |
Как прокрутить ListBox по вертикали? | TwiX | Общие вопросы Delphi | 5 | 29.07.2009 21:23 |
Как склеить документы? | drooon | Microsoft Office Word | 1 | 04.01.2009 02:28 |