Спасибо!
Таблица подстановки работает не всегда
Проверка 2-х искомых значений
Автоматическое объединение нескольких книг Excel в одну // Upgrade!!
Автоматическое объединение нескольких книг Excel в одну // Upgrade!!
Автоматическое объединение нескольких книг Excel в одну // Upgrade!!
Автоматическое объединение нескольких книг Excel в одну // Upgrade!!
Автоматическое объединение нескольких книг Excel в одну // Upgrade!!
02.12.2010 14:45:00
Здравствуйте!
Подскажите пожалуйста, как можно подправить данный код (взят с - имена нужных файлов указаны/прописаны заранее (их штук 10) - во всех книгах берутся данные только с одного листа (во всех книгах называется одинаково) - строки собираются на конкретный лист конкретной книги (в которой макрос и расположен) Вот сам макрос: {quote}Sub Объединение_файлов() Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _ i As Integer, stbar As Boolean 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) .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 shTarget = wbTarget.Sheets.Add(after:=wbTarget.Sheets(wbTarget.Sheets.Count)) shTarget.Name = Left(Replace(wbSrc.Name, ".xls", "") & "." & shSrc.Name, 31) shSrc.Cells.Copy shTarget.Range("A1") End If Next wbSrc.Close False 'закрыть без запроса на сохранение Next .ScreenUpdating = True .DisplayStatusBar = stbar .StatusBar = False If wbTarget.Sheets.Count = 1 Then 'не добавлено ни одного листа MsgBox "В указанных книгах нет непустых листов, сохранять нечего!" wbTarget.Close False End Else .DisplayAlerts = False wbTarget.Sheets(1).Delete .DisplayAlerts = True End If 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{/quote} |
|
|
Беседка сводников, или вопросы по сводным таблицам.
Помогите с решением. Поиск по части содержимого.
Помогите с решением. Поиск по части содержимого.
Беседка сводников, или вопросы по сводным таблицам.
Беседка сводников, или вопросы по сводным таблицам.
Беседка сводников, или вопросы по сводным таблицам.
Беседка сводников, или вопросы по сводным таблицам.
Беседка сводников, или вопросы по сводным таблицам.
10.05.2010 10:17:10
{quote}{login=Serge 007}{date=21.03.2010 07:47}{thema=}{post}
Сергей, объясни пож-та, как сделать такой запрос... чтоб получилась база, объединяющая несколько таблиц с одинаковыми заголовками. С остальным я наверное справлюсь. |
|
|
сводная таблица из нескольких источников
Возможно ли?
Возможно ли?
Возможно ли?