Страницы: 1
RSS
Объединение нескольких книг Exel в одну
 
Нашел интересную тему по объединению нескольких книг в одну (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 например), то вследствие такой вставки ее значение уже некорректное.
azat
 
Здравствуйте! Не знаю, услышат ли здесь... Тема старая.    
Успешно прменял макрос: с текстовыми файлами. Стало нужно применить его с файлами "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>Но вопрос такой: нужно чтобы из второго и последующего файлов, не копировалась первая строка с шапкой. Не нашёл ответа на это в форуме. Подскажите, пожалуйста. Спасибо.
 
Не проверял, может не сработает, но попробуйте:  
 
вверху  
Dim tbl as Range  
 
ниже замените блок "For Each" на этот:  
 
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
Страницы: 1
Читают тему
Наверх