|
|
Регистрация Восстановить пароль |
Повторная активизация e-mail |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
25.04.2011, 08:24 | #1 |
Регистрация: 22.04.2011
Сообщений: 7
|
Сбор данных только первых листов разных книг
Есть код объединения файлов. Как его можно подправить чтобы собирать только первые листы всех файлов.
Sub Дистрибьюция() Const strStartDir = "Z:\Новая папка" 'папка, с которой начать обзор файлов Const strSaveDir = "Z:\Новая папка\result" 'папка, в которую будет предложено сохранить результат 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(shTarge t.Range("A1").SpecialCells(xlCellTy peLastCell).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 |
25.04.2011, 08:50 | #2 |
Старожил
Регистрация: 05.12.2007
Сообщений: 4,180
|
Не вникал в код, но, по-моему, достаточно после строки
Код:
Код:
Чем шире угол зрения, тем он тупее.
|
25.04.2011, 09:15 | #3 |
Регистрация: 22.04.2011
Сообщений: 7
|
Что-то несрабатывает также продолжает собирать все листы.
|
25.04.2011, 09:42 | #4 |
Программист VBA
СуперМодератор
Регистрация: 13.07.2008
Сообщений: 6,856
|
Код:
|
25.04.2011, 12:07 | #5 |
Регистрация: 22.04.2011
Сообщений: 7
|
Все отлично работает. СПАСИБО!!!
|
25.04.2011, 15:43 | #6 |
Регистрация: 22.04.2011
Сообщений: 7
|
Задача усложнилась. Теперь нужно собрать не просто первые листы, а только определенные данные с первого листа.
Есть несколько перечней номеров. Каждый номер имеет определенный складской код. Необхоимо собрать перечни по складским кодам. |
25.04.2011, 17:50 | #7 | ||
Программист VBA
СуперМодератор
Регистрация: 13.07.2008
Сообщений: 6,856
|
Цитата:
Цитата:
В чем ваш вопрос? Или просто решили горем поделиться? ) |
||
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
сбор данных с разных книг в одну | Ledy1987 | Microsoft Office Excel | 26 | 20.04.2011 21:33 |
Сбор данных с разных книг и работа с ними | budda999 | Microsoft Office Excel | 1 | 19.01.2011 18:37 |
Сбор даных с разных книг в одну | Pao | Microsoft Office Excel | 28 | 12.07.2010 07:27 |
Формирование реестра из данных первых листов книг | z21231904 | Microsoft Office Excel | 12 | 03.06.2010 23:05 |
Сбор данных из разных книг | 804040 | Microsoft Office Excel | 2 | 19.04.2010 15:33 |