Страницы: 1
RSS
Объединение нескольких книг в один лист
 
Для объединения множества книг в один я использую нижеуказанный макрос (нашел где то в интернете). Удобная программа. Выделяешь книги, а он объединяет все в один лист друг за другом.  
Вопрос в другом. Он вставляет полностью с формулами. А возможно ли изменить макрос чтобы он вставлял только значения? (без формул, без форматов..)  
 
 
-----------------------------------------------------------  
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  
----------------------------------------
 
Вставьте строчку  
shSrc.UsedRange.Copy  
clTarget.PasteSpecial xlPasteValues
 
{quote}{login=Igor67}{date=04.11.2009 02:59}{thema=}{post}Вставьте строчку  
shSrc.UsedRange.Copy  
clTarget.PasteSpecial xlPasteValues{/post}{/quote}  
 
я мало разбираюсь в VBA. А куда именно вставить?
 
{quote}{login=brico}{date=04.11.2009 05:21}{thema=Re: }{post}{quote}{login=Igor67}{date=04.11.2009 02:59}{thema=}{post}Вставьте строчку  
shSrc.UsedRange.Copy  
clTarget.PasteSpecial xlPasteValues{/post}{/quote}  
 
я мало разбираюсь в VBA. А куда именно вставить?{/post}{/quote}  
кажется понял.  
Спасибо. все работает как надо.
 
Еще одна проблема.    
Как только вставил эти строки появилась. Теперь он каждый раз спрашивает сохранить ли в буфере обмена эти данные. Я отвечаю нет. Но если файлов несколько десятков, то утомляет нажимать на нет!.  
Что можно дописать в макрос и куда, чтобы он автоматически сам нажимал на нет ?
 
{quote}{login=The_Prist}{date=06.11.2009 10:17}{thema=}{post}Как вариант перед выполнением цикла поставьте такую строку  
Application.displayalerts = false  
а после выполнения цикла  
Application.displayalerts = true  
 
Но можно еще после строк  
shSrc.UsedRange.Copy  
clTarget.PasteSpecial xlPasteValues  
Поставить    
Application.cutcopyMode = false{/post}{/quote}  
спасибо. То что нужно!!
 
К сожалению я не могу понять куда ставить данные строки((((  
ПОМОГИТЕ
 
{quote}{login=Салли}{date=20.05.2011 08:15}{thema=}{post}К сожалению я не могу понять куда ставить данные строки((((  
ПОМОГИТЕ{/post}{/quote}  
 
Я пыталась поставить в каждую строку из диапазона:  
 For i = 1 To UBound(arFiles)  
 ...  
 .StatusBar = False  
 
Но все равно вставляются формулы
 
Большое спасибо!  
 
И еще вопрос: как избавиться от шапок таблиц?
 
Каких шапок?
 
В каждом файле присутствуют таблицы с одинаковыми данными (в том числе шапки таблиц)    
Например, первая строка данных начинается с n-ной строки
 
Подскажите, пожалуйста, как изменить строку так, чтобы открывались все файлы Excel?  
 
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
 
Спасибо, нашла!
 
{quote}{login=Саламандра}{date=10.10.2011 04:34}{thema=}{post}Подскажите, пожалуйста, как изменить строку так, чтобы открывались все файлы Excel?  
 
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True){/post}{/quote}  
 
Самому понадобился такой скрипт, но надо было, чтобы открывались DBF файлы. Сам в VBA ничего не знаю, но в справке Microsoft нашел описание параметра .GetOpenFilename и изменил этот скрипт:  
 
arFiles = .GetOpenFilename("All Files (*.*), *.*", , "Объединить файлы", , True)
Страницы: 1
Наверх