|
Компьютерный форум OSzone.net » Программирование, базы данных и автоматизация действий » Программирование и базы данных » VBA - Сбор данных с определенного листа большого кол-ва книг на один лист |
|
|
VBA - Сбор данных с определенного листа большого кол-ва книг на один лист
|
Старожил Сообщения: 329 |
Всем доброго времени суток.
Недолго думая я погуглил, нашел как листы скопировать со всех книг в одну. Погуглил ещё нашел как всю информацию записать на 1 лист. Подкорректировал, сделал, чтоб сразу как надо было, но увы, меня ждала неудача. Теряется 1 строка при копировании информации с последующей книги. Код у меня такой Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets(3).Range("A1:Z" & Sheets(3).UsedRange.Rows.Count + 1).Copy ThisWorkbook.Sheets(1).Range("A" & ThisWorkbook.Sheets(1).UsedRange.Rows.Count + 1) x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub |
|
------- Отправлено: 23:03, 24-04-2018 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
![]() Цитата blackeangel:
Цитата blackeangel:
Что я бы наверняка поменял: Workbooks.Open Filename:=FilesToOpen(x) Sheets(3).Range("A1:Z" & Sheets(3).UsedRange.Rows.Count + 1).Copy ThisWorkbook.Sheets(1).Range("A" & ThisWorkbook.Sheets(1).UsedRange.Rows.Count + 1) Dim objWorkbook As Workbook … Set objWorkbook = Workbooks.Open(Filename:=FilesToOpen(x)) objWorkbook.Sheets(3).Range("A1:Z" & objWorkbook.Sheets(3).UsedRange.Rows.Count + 1).Copy … … objWorkbook.Close В общем, крайне желательны образцы. |
|||
Отправлено: 23:42, 24-04-2018 | #2 |
Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети. Если же вы забыли свой пароль на форуме, то воспользуйтесь данной ссылкой для восстановления пароля. |
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Iska, примерчики приложу чуть позже.
Да, копировать именно надо в один лист. Задача на самом деле куда шире: надо из выбранных файлов сгруппировать по дате создания, содержимое третьего листа всех сгруппированных файлов(группировка по месяцам) прочитать на временный лист, удалить дубли,проставить в свободный столбец месяц и год. На новый лист подвести итог - кол-во записей с предыдущего листа по месяцам. На счёт того кто косячит: косячит именно та строка что вы усомнились. Не происходит сдвиг курсора на строку ниже, а запись начинает сразу в последнюю строку. Добавляя +1 я пытался исправить это положение, но безуспешно. Если это всё хозяйство разбить на 2 этапа: в книгу собираем нужные листы из других книг, а потом пробегаясь по листам собирать данные на один лист - то всё работает правильно. А вот сразу на лету - нет. Для уточнения-теряется последняя строка предыдущего копирования. Всё описал как то сумбурно, но как смог. |
------- Отправлено: 06:52, 25-04-2018 | #3 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать blackeangel, ну, вот, как раз потому я и прошу образцы Рабочих книг, дабы было на чём «щупать» код.
|
Отправлено: 14:01, 25-04-2018 | #4 |
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Iska, вот и файлики. Только пришлось подрезать их до 1 листа.
|
|
------- Отправлено: 14:10, 25-04-2018 | #5 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
Э… Теперь Вы собираете рабочие листы в одной Рабочей книге? Цитата blackeangel:
Option Explicit Sub CombineWorkbooks() Dim arrSelectedWorkbooks As Variant Dim strWorkbook As Variant arrSelectedWorkbooks = Application.GetOpenFilename( _ FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _ Title:="Files to Merge", _ MultiSelect:=True _ ) If IsArray(arrSelectedWorkbooks) Then For Each strWorkbook In arrSelectedWorkbooks With Application.Workbooks.Open(Filename:=strWorkbook) .Sheets.Item("Сборки для диспетчера").UsedRange.Copy ThisWorkbook.Sheets.Item(1).UsedRange.Offset(ThisWorkbook.Sheets.Item(1).UsedRange.Rows.Count) .Close End With Next strWorkbook Else MsgBox "Не выбрано ни одного файла!" End If End Sub а) на рабочем листе сборки первая строка останется пустой (потому как и на пустом рабочем листе свойство .UsedRange пустым не бывает), в принципе, это можно учесть, я просто не стал усложнять здесь код; б) сборка происходит с заголовками «№ сборки», это тоже можно учесть и исключить. |
||
Отправлено: 15:19, 25-04-2018 | #6 |
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Цитата:
|
|
------- Отправлено: 16:30, 25-04-2018 | #7 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
|
|
Отправлено: 17:14, 25-04-2018 | #8 |
Старожил Сообщения: 329
|
Профиль | Отправить PM | Цитировать Iska, разобрался. Да, действительно на лету.
Как бы это переделать теперь чтоб предлогалось выбрать листы(номер или имя), а если не указаны, то всю книгу целиком. Но запрос только один раз был, а не по каждой книге) да, и отвязаться от thisworkbook как? Чтоб было что то типа activeworkbook. Но при открытии ведь activeworkbook меняется на вновь открытый файл. В общем почти что модуль надстройки) |
------- Отправлено: 17:21, 25-04-2018 | #9 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Цитата blackeangel:
Цитата blackeangel:
Цитата blackeangel:
|
|||
Отправлено: 17:59, 25-04-2018 | #10 |
|
![]() |
Участник сейчас на форуме |
![]() |
Участник вне форума |
![]() |
Автор темы |
![]() |
Сообщение прикреплено |
| |||||
Название темы | Автор | Информация о форуме | Ответов | Последнее сообщение | |
Подскажите программу(определение субтитров у большого кол-ва файлов)! | Aviator | Видео и аудио: обработка и кодирование | 0 | 09-05-2015 21:27 | |
Разное - [решено] открытие большого кол-ва html файлов | Alexander_88 | Microsoft Windows 8 и 8.1 | 5 | 20-04-2015 20:55 | |
CMD/BAT - [решено] Убрать расширение с большого кол-ва файлов | cher | Скриптовые языки администрирования Windows | 4 | 30-03-2015 16:31 | |
2010 - [решено] Excel 2010 фильтр 1 и 2 листа скопировать на новый лист | The Off | Microsoft Office (Word, Excel, Outlook и т.д.) | 30 | 03-08-2013 09:18 | |
выбор принтера для печати большого кол-ва фотографий | Kibor_G | Выбор отдельных компонентов компьютера и конфигурации в целом | 0 | 18-06-2010 12:03 |
|