mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Сбор данных из файлов Excel в заданной папке

Обработка данных из файлов Excel - отображение информации на индикаторе состояния

Этот макрос предназначен для сбора (загрузки) информации из файлов Excel, расположенных в одной папке.

 

Для работы этого макроса, помимо него самого, вам понадобится добавить в свой файл:

  1. функцию FilenamesCollection для получения списка файлов в папке
  2. функцию GetFolder для вывода диалогового окна выбора папки с запоминанием выбранной папки
  3. прогресс-бар для отображения процесса обработки файлов (модуль класса и форму)

 

Если при тестировании макроса у вас возникает ошибка, что не найдена та или иная функция,
— проверьте, все ли необходимые компоненты (которые перечислены выше) вы добавили в свой файл.

Этот макрос я публикую прежде всего для себя (поскольку использую этот код чуть ли ни в каждой третьей своей программе),
поэтому я не буду помогать вам в настройке этого макроса, если у вас он вдруг не заработает.

 

Макрос при запуске выдает диалоговое окно для выбора папки, в которой расположены обрабатываемые файлы,
после чего открывает каждый из файлов, считывает из него данные, помещает их в текущую книгу (из которой запущен макрос),
и закрывает обработанный файл без сохранения изменений.

После того, как очередной файл обработан, он перемещается во вторую папку («архив»).

 

Код макроса:

Sub ИмпортДанныхИзЗаявок()
    On Error Resume Next: Err.Clear
    ' запрашиваем пути к папкам с файлами
    InvoiceFolder$ = GetFolder(1, , "Выберите папку с файлами заявок (из Outlook)")
    If InvoiceFolder$ = "" Then MsgBox "Не задана папка с заявками", vbCritical, "Обработка заявок невозможна": Exit Sub
 
    ArchieveFolder$ = GetFolder(2, , "Выберите папку, куда будут помещаться обработанные файлы заявок")
    If ArchieveFolder$ = "" Then MsgBox "Не задана папка для архива заявок", vbCritical, "Обработка заявок невозможна": Exit Sub
 
    Dim coll As Collection
    ' загружаем список файлов по маске имени файла
    Set coll = FilenamesCollection(InvoiceFolder$, "Заявка №*от*.xls*", 1)
 
    If coll.Count = 0 Then
        MsgBox "Не найдено ни одной заявки для обработки в папке" & vbNewLine & InvoiceFolder$, _
               vbExclamation, "Нет необработанных заявок"
        Exit Sub
    End If
 
    Dim pi As New ProgressIndicator: pi.Show "Обработка заявок", , 2
    pi.StartNewAction , , , , , coll.Count    ' отображаем прогресс-бар

    Dim WB As Workbook, sh As Worksheet, ra As Range
    Application.ScreenUpdating = False  ' отключаем обновление экрана (чтобы процесс открытия файлов не был виден)

    ' перебираем все найденные в папке файлы
    For Each Filename In coll
 
        ' обновляем информацию на прогресс-баре
        pi.SubAction "Обрабатывается заявка $index из $count", "Файл заявки: " & Dir(Filename), "$time"
        pi.Log "Файл: " & Dir(Filename)
 
        ' открываем очередной файл в режиме «только чтение»
        Set WB = Nothing: Set WB = Workbooks.Open(Filename, False, True)
 
        If WB Is Nothing Then    ' не удалось открыть файл
            pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
 
        Else    ' файл успешно открыт
            Set sh = WB.Worksheets(1)    ' будем брать данные с первого листа
            ' берем диапазон ячеек с ячейки B1 до последней заполненной в столбце B
            Set ra = sh.Range(sh.Range("b1"), sh.Range("b" & sh.Rows.Count).End(xlUp))
 
            ' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
            shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
            Application.WorksheetFunction.Transpose(ra.Value)
            ' ==== конец обработки данных из очередного файла

            WB.Close False: DoEvents    ' закрываем обработанный файл без сохранения изменений
            pi.Log vbTab & "Файл успешно обработан."
 
            ' перемещаем обработанный файл из папки InvoiceFolder$ в папку ArchieveFolder$
            Name Filename As ArchieveFolder$ & Dir(Filename, vbNormal)
 
        End If
    Next
 
    ' закрываем прогресс-бар, включаем обновление экрана
    pi.Hide: DoEvents: Application.ScreenUpdating = True
    MsgBox "Обработка заявок завершена", vbInformation
End Sub


 

Во вложении - файл со всеми необходимыми макросами для сбора данных из других файлов Excel

ВложениеРазмерЗагрузкиПоследняя загрузка
MergeWorkbooks.xls117 КБ1446 дней 9 часов назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Да разобрался. А вот такой вопросик, если в каждой книге по 10 листов и более, а надо брать всего лишь один к примеру в 17 книгах будет одинаковый лист 2017 и надо брать только его, это тоже идет доработка?

Нет там никакого ограничения по запускам (код открыт, можете сами убедиться)
Расширить столбцы ничто вам не мешает, никаких ограничений и защит в прикреплённом файле нет
Где что подправить - не подскажу (техподдержки по бесплатным макросам нет)
Если сами не разберетесь, - могу сделать под заказ (минимальная стоимость заказа - 1500 руб)

Добрый День!. Я смотрю у вас макрос расчитан на 3000 запусков а потом всё? И второй момент, расшить столбцы более J это уже платно? или где то подправить я могу, я смотрю вы все диапазонами обзывали в макросах собирающихся.

Проблемма решилась самостоятельно, нужно было всего лишь переоткрыть файл для применения изменений формата.

Доброго времени суток, не могли бы вы подсказать, почему при коллекционировании более, чем 64000 строк макрос перестает вставлять данные?
книга была сохранена в формат .xlsb
ошибка следующая:
для
shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value
выдает сообщение: "Application-defined or object-defined error"

Оформляйте заказ на сайте, - сделаем.

Уважаемы гуру VBA помогите новичку не провалить задание.
Дело в том, что с разных отделов ( около 40) мне шлют заполненную таблицу Excel, универсальную для всех.
Разница лишь в цифрах, которые туда заносит каждый отдел исходя из своих показателей. Мне нужно создать сводную, одну таблицу, которая бы суммировала значения всех отделов. Неизменными остаются -шапка таблицы и столбец с названием показателей. Помогите создать макрос.

Спасибо, очень помог макрос после небольшой доработки!

Доброго времени суток!
Скачал Ваш файл с макросами. Как теперь добавить необходимую мне информацию из книг, откуда идет сбор информации, в эту книгу?
Спасибо за ответ.

Иван, оформляйте заказ, прикрепляйте к нему примеры файлов, и подробно описывайте, что и как должно работать.

Добрый день. Вот такая есть у меня задачка, в Excel я чайник. Помогите решить ее. Суть в следующем. Есть некое количество файлов Excel в папке, каждый день разное (от 100 до нескольких тысяч), нужен вывод названия каждого файла в общую таблица, строка названия файла в графе с подсчетом строк в каждом фале, исключая шапку, общие число файлов.И желательно интеграция в word. Как прикрепить таблицы для примера?

Добрый день!

нарисовал в коде вот так:

'If (sh.Range("c45") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e45"))
'End If 'Направления использования - командировочные

'If (sh.Range("c47") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e47"))
'End If 'Направления использования - хозрасходы

'If (sh.Range("c49") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e49"))
'End If 'Направления использования - внесение средств

'If (sh.Range("c51") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e51"))
'End If 'Направления использования - Иное

Все отлично работает и в итоговую таблицу записывается значение из соответствующего столбца "e" если в столбце "с" только одно вхождение "1". В противном случае если "1" несколько то в таблицу добавляются дополнительные строки. Можно как то поправить, что бы при нескольких вхождениях "1" в столбце "c" в итоговую таблицу записывались данные соответствующей строки из столбца "e" в одну ячейку через разделитель.

Спасибо, сработало)

так попробуйте

With shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1, 1).Resize(ra.Rows.Count, ra.Columns.Count)
    .Value = ra.Value ' начиная со второго столбца, вставляем 10 столбцов данных
    .EntireRow.Columns(1).Value = WB.Name ' в первый столбец вставляем имя файла
End With

Пытаюсь добавть название файла. Макрос либо вставляет только название файла в 10-ю ячейку, либо ничего не вставляет
With shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value
.EntireRow.Cells(ra.Rows.Count, 10) = WB.Name
End With

Да, можно. Поищите пример кода в комментах (вроде было)
Либо можем сделать под заказ (если готовы оплатить)

Добрый день!

Можно ли добавить для каждой строчки в последний столбец название файла, из которого была вставка? спасибо

Благо Дарю за ответ! Подсказка была уместной, получилось! Удачи!

Да нет там никаких ограничений...

в коде задано количество столбцов, считываемых их обрабатываемого файла

' берем диапазон ячеек с ячейки A2 до последней заполненной в столбце A
Set ra = sh.Range(sh.Range("a2"), sh.Range("a" & sh.Rows.Count).End(xlUp)).Resize(, 10)

число 10 здесь - количество столбцов

Сколько столбцов считано - столько и выведется в сводный файл
В сводном файле столбцы после 10-го скрыты (ничто не мешает вам их отобразить)

Доброго дня Николай! Скажите, Вы решили проблему ограничения столбцов в макосе MergeWorkbooks.xls? если да, то поделитесь опытом! Всего доброго!

У меня макрос работает только с первыми 10 столбцами. Подскажите, пожалуйста, что делать, если в обрабатываемой таблице 20 столбцов? Как убрать ограничение?

Для копирования ячеек с форматированием + гиперссылки меняем строку в макросе скачанного файла
прям всё переделывать не нужно всего 1-ну строку

' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
sh.Range(sh.Range("a2"), sh.Range("a" & sh.Rows.Count).End(xlUp)).Resize(, 10).Copy Destination:=shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count)
' ==== конец обработки данных из очередного файла
и очистка формата на
On Error Resume Next: shd.UsedRange.Offset(2).Clear

Люди пользуйтесь

А ВЫ УШЛЫЕ ВЫ БАБУЛЬКИ !!!!

Есть такая функция у меня на сайте
http://excelvba.ru/code/JoinedArray

привет , такая проблемка , нужно соеденить одинаковые строки с одинаковыми значаниями в макросе, не подскажите как это сделать ?

Для этого надо переделывать макрос, и надо видеть файлы ваши, чтобы переделать.
Могу сделать под заказ.

Как допилить, что бы скрипт собирал ячейки копировались с гиперссылками а не только заначение

Николай, чтобы не было ограничения в 65 тыс строк, просто пересохраните файл с макросом в формате «двоичная книга Excel» (расширение XLSB) или «Excel 2007 с поддержкой макросов» (расширение XLSM)
И будет у вас в файле миллион строк.


Юрий, чтобы имя файла выводилось, надо заменить код
' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
            shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
            Application.WorksheetFunction.Transpose(ra.Value)
            ' ==== конец обработки данных из очередного файла

на что-то типа такого
' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
With shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count)
    .Value = Application.WorksheetFunction.Transpose(ra.Value)
    .EntireRow.Cells(6) = wb.Name        ' имя файла в 6 столбец
End With
' ==== конец обработки данных из очередного файла

А как сделать, чтобы чтобы не было ограничений по строкам, а то максимум получается 65000 строк?

Подскажите, как сделать, что нужно добавить или изменить в данном макросе чтобы
в отдельном столбце, например в стобце F отображалось название файла с которого был перенос данных.
Спасибо за ответ.

Спасибо за макрос, переделал по свои нужды. Автору Респект!

Спасибо за макрос
Мне нужно изменить строчку
Set ra = sh.Range(sh.Range("b1"), sh.Range("b" & sh.Rows.Count).End(xlUp))
Я хочу чтобы 10 строка только копировалась
Я изменил ее на
Set ra = sh.Range(sh.Range("a10"), sh.Range("x" & sh.Rows.Count).End(xlUp)).Resize(, 25)
то есть копираует с а10 по х10
Проблема в том что он тянет все строки с а1 по а10. а Мне только нужна 10 строка
Помогите пожалуйста

Здравствуйте, Дмитрий.
Да, можно.

Здравствуйте! Подскажите пожалуйста а можно в файл Excel загрузить данные из другого Файла excel, с указание путь к загрузочному файлу

Уважаемые специалисты,

Подскажите, пожалуйста, как изменить строку shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value таким образом, чтобы результат записывался не в столбец, а в строку?

Спасибо.

В коде (тем более, прогресс-бара), скорее всего, косяков нет
Возможно, с обрабатываемыми файлами что-то не так.
Я не занимаюсь техподдержкой бесплатных макросов, - потому, подсказать ничего не смогу.
Если нужно готовое решение, - можем сделать под заказ.

Есть косяк в отображении логов в прогресс-баре
https://www.youtube.com/watch?v=Za2E3HI0tOw

На четвертом или пятом файле глюк. Потом до конца нормально отображает.
Подскажите где копать?

Эдуард, замените эти 2 строки кода на одну типа такой:

shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 5).Value = array(sh.Range("a1"),sh.Range("a2"),sh.Range("b33"),sh.Range("f4"),sh.Range("f6"))

Здравствуйте.
Спасибо за отличный макрос, то что мне нужно, только надо поправить пару строк...
Set ra = sh.Range(sh.Range("n2330"), sh.Range("n" & sh.Rows.Count).End(xlUp)).Resize(, 1)

shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value

Мне нужен не массив данных, а вставка 4-5 конкретных ячеек в одну строку, не подскажете как изменить эти строчки?
Спасибо

В статье не весь код написан.
Во вложении к статье, - файл со всеми необходимыми макросами.
Откройте этот файл, - и скопируйте оттуда весь код (+ модуль класса и форму прогресс-бара)

Добрый день. Хотел посмотреть работу макроса и скопировал данный код себе в vba. При запуске макроса в отношении функции GetFolder сразу же вылетает ошибка : Compile error , Sun or Function not defined. Попробовал в библиотеке поискать эту функцию и также не нашел. Excel 2013 стоит. Что не так?

Здравствуйте, Рафаэль.
Да, конечно можно.
Оформляйте заказ на сайте, прикрепляйте примеры файлов, и подробно описывайте, что и как должно работать.

здравствуйте а можно у вас сделать заказ на макрос. вывести 2 диалоговых окна чтоб там можно было менять параметры наприме брать с 1 или 2 листа , и с какой ячейки брать данные

Сохраните файл в формате xlsm.
У вас скорее всего не помещаются по столбцам данные.
В xls формате их мало.
И надо как-то на стартовом листе кол-во столбцов увеличить, т.к. каким-то способом они там скрыты.
Или по инструкции ниже сделать импорт на конкретный лист. Тогда можно в книгу добавить лист и на него сослаться.

Минимальная стоимость заказа у нас, — 1000 рублей
Да, Webmoney мы принимаем

Сколько будет стоить? и можно ли оплатить вебмани WMZ.

Здравствуйте, Вячеслав.
Сделать-то несложно (несколько строк кода добавить), но я не занимаюсь бесплатной доработкой бесплатных макросов.
Можем сделать под заказ (недорого)

Добрый день,
Как сделать чтоб ещё добавлялось название файла и данные определённой ячейки (из листов хоронящихся в папке).
Если не сложно. Буду очень признателен.

Спасибо разобрался с границами ячеек. Камент не нужен

Здравствуйте.Подскажите пожалуйста, после добавления колонок в сводную таблицу, данные переносятся, все ок, НО у ячеек в добавленных столбцах нет границ. Все обшарил - не нашел ((

Разобрался :) Теперь сижу построчно все разбираю как работает.Буду пробовать вставить имена файлов откуда берется все в первый столбец. Ну и еще что нибудь :) А вообще как пример что можно сделать очень хороший.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _       ____                    _   _   _ 
| |__ | _ \ _ __ _ __ | | | | | |
| '_ \ | |_) | | '_ \ | '_ \ | |_| | | |
| |_) | | __/ | | | | | | | | | _ | | |
|_.__/ |_| |_| |_| |_| |_| |_| |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.