Нашел интересную тему по объединению нескольких книг в одну (http://forum.ixbt.com/topic.cgi?id=23:34091), там есть код модуля позволяющего объединять несколько разных документов в один: Sub FiziK()
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
Появиласть вот какая идея. А если есть необходимость свести в 1 таблицу не все листы с документов, а какую либо определенную часть отмеченную выделением или имеющую определенную заливку (как объединение листов в PLEXe по заливке). Думаю получиться отличная новая функция! У кого какие идеи есть?
Вышеуказанный макрос работает отлично.. А можно его как то доработать, чтобы он сделал тоже самое, но, чтобы выполнил как в случае использования функции: 1. Правая кнопка мыши->специальная вставка->Только значения 2. Правая кнопка мыши->специальная вставка->Только форматы ???? А то есть такой косяк... предположим формала, которая ссылается на только определенную ячейку ($A$50 например), то вследствие такой вставки ее значение уже некорректное.
Здравствуйте! Не знаю, услышат ли здесь... Тема старая. Успешно прменял макрос: с текстовыми файлами. Стало нужно применить его с файлами "xlsb". Просто заменил расширения. Работать перестал. Во первых, собирает не все файлы, а только три -четыре (без системы). Во вторых, пишет "книга не сохранена". Где ошибка и что исправить? Подскажите пожалуйста! Код такой:
Sub FiziK() 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 (*.xlsb), *.xlsb", , "Объединить файлы", , 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 (*.xlsb), *.xlsb", , "Сохранить объединенную книгу")
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
Приветствую Вас - О жители ПЛАНЕТЫ! Некогда со страницы http://www.planetaexcel.ru/forum.php?thread_id=2842, форума, мне помогли собрать несколько файлов в одну книгу. Текст макроса выше. <BR>Но вопрос такой: нужно чтобы из второго и последующего файлов, не копировалась первая строка с шапкой. Не нашёл ответа на это в форуме. Подскажите, пожалуйста. Спасибо.
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 Set tbl = shSrc.UsedRange tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Copy clTarget 'сдвиг таблицы на строку вниз и низ на строку вверх End If Next