Страницы: 1
RSS
Объединение книг в один лист, Объединение всех выбранных книг Excel в один лист
 
Здравствуйте! Хотелось бы объединить все выбранные книги в один лист. Нашел код на этом же сайте, но уже в Архиве, и были эти же вопросы, но отвечали походу в ЛС и поэтому ответов там нет. Были только после вопросов сразу же "Спасибо, все получилось".
Просто нужно немного изменить этот код.

Ну и собственно вопросы:
1) Как объединить все выбранные книги Excel (*.xls и *.xlsx), пробывал изменить на *.xls*, но почему то ругается на *.xlsx
2) Как выбрать с какой строки копировать? В объединяемых книгах есть шапки таблиц, которые желательно не объединять.
3) Ну и если есть возможность, то как при сохранении сделать выпадающий список по выбору расширения сохраняемой книги (*.xls или *.xlsx)
Код
Sub Объединение_множества_книг_в_один_лист()   
  
Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов   
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат   
Const blInsertNames = True 'вставлять строку заголовка (книга, лист) перед содержимым листа   
  
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _   
i As Integer, stbar As Boolean, clTarget As Range   
  
On Error Resume Next 'если указанный путь не существует, обзор начнется с пути по умолчанию   
ChDir strStartDir   
On Error GoTo 0   
With Application 'меньше писанины   
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)   
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла   
Set wbTarget = Workbooks.Add(template:=xlWorksheet)   
Set shTarget = wbTarget.Sheets(1)   
.ScreenUpdating = False   
stbar = .DisplayStatusBar   
.DisplayStatusBar = True   
  
For i = 1 To UBound(arFiles)   
.StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)   
Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)   
For Each shSrc In wbSrc.Worksheets   
If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой   
Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)   
If blInsertNames Then   
clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name   
Set clTarget = clTarget.Offset(1, 0)   
End If   
shSrc.UsedRange.Copy clTarget   
End If   
Next   
wbSrc.Close False 'закрыть без запроса на сохранение   
Next   
.ScreenUpdating = True   
.DisplayStatusBar = stbar   
.StatusBar = False   
  
On Error Resume Next 'если указанный путь не существует и его не удается создать,   
'обзор начнется с последней использованной папки   
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir   
ChDir strSaveDir   
On Error GoTo 0   
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")   
  
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя   
GoTo save_err   
Else   
On Error GoTo save_err   
wbTarget.SaveAs arFiles   
End If   
End   
save_err:   
MsgBox "Книга не сохранена!", vbCritical   
End With   
End Sub 

Заранее спасибо большое!
Изменено: Amirchik - 16.05.2019 16:37:30
 
Amirchik, а вам-то как именно надо объединять? Мы ведь не знаем. А следовательно и код может отличаться. Хотелось бы знать что и как, какие размеры диапазонов и прочее.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.
 
Этот код меня почти устраивает, он объединяет почти как надо. Кроме тех вопросов которые я написал.
Есть N-ое количество выбранных книг, просто объединить их, но копировать, например, с 6ой строки. Ну и не зависимо от XLS или XLSX.
Просто нужно какая то маленькая редакция этого кода, а вот как че то сообразить не могу =\
Изменено: Amirchik - 15.05.2019 20:39:24
 
Ладно, фиг бы с этими вопросами, есть другая проблема в этом коде, SCREEN UPDATING не правильно работает на 2016 офисе (может и на других, нет возможности проверить). Как можно исправить?
Если перекинуть screenupdating выше, то Excel полностью исчезает и только после полного выполнения макроса появляется.
Помогите со ScreenUpdating-ом ))
 
Лучше выложите пример файлов, как есть и как надо. Дело будет двигаться гораздо быстрее...
Изменено: Андрей_26 - 16.05.2019 23:24:27
 
Ну вот просто наброски. Но в реале они весят по больше, здесь не разрешено больше 100КБ грузить.
Короче, во время объединения видится только коричневый экран (знаю только стандартные цвета)))). А хотелось бы чтоб остался тот лист на котором запустили макрос и виден был процесс объединения:
Код
For i = 1 To UBound(arFiles)   
.StatusBar = "Обработка файла " & i & " из " & UBound(arFiles) 
Если не будет видеться этим кодом, хотя бы чтоб на форме макроса показывался:
Код
UserForm1.Label1.Caption = "Обработка файла " & i & " из " & UBound(arFiles)
UserForm1.Repaint

Но ScreenUpdating замораживается в какой то не понятный момент.
Походу не смогу я понятно объяснить  :sceptic:  
 
Цитата
Amirchik написал:
виден был процесс объединения:
Для чего Вам видеть процесс объединения ? Это будет только тормозить выполнение макроса. Экран будет моргать и только раздражать.
 
Ну можно же наверно остановить обновление экрана и обновлять только форму макроса REPAINT-ом или я ошибаюсь :sceptic:  
 
Amirchik, видеть из какого именно файла взяты какие строки нужно?
Решение принципиально нужно макросом? Power Query для данной задачи прямо рожден. Раз уж у вас 2016 офис.
Вот вариант запроса. Сделал его минуты за 3. Выгребает данные из всех книг с листа Sheet1 начиная с шестой строки.
Путь к папке только в рыжей ячейке поменяйте. И еще, данному запросу по барабану тип файла xls или xlsx.
Изменено: PooHkrd - 17.05.2019 12:07:05
Вот горшок пустой, он предмет простой...
 
Цитата
написал:
Amirchik, видеть из какого именно файла взяты какие строки нужно?
Решение принципиально нужно макросом? Power Query для  данной задачи  прямо рожден. Раз уж у вас 2016 офис.
Вот вариант запроса. Сделал его минуты за 3. Выгребает данные из всех книг с листа Sheet1 начиная с шестой строки.
Путь к папке только в рыжей ячейке поменяйте. И еще, данному запросу по барабану тип файла xls или x
А как задать выгрузку с шестой строки
 
Вместо
Код
shSrc.UsedRange.Copy clTarget
строка
Код
shSrc.UsedRange.Offset(5).Copy clTarget
 
Готовое решение
Страницы: 1
Наверх