Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Читайте новые сообщения форума форума в RRS-агрегаторах

Автор Тема: Суммирование ячеек из разных книг в сводную  (Прочитано 133 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Владимир Попов

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 10

Добрый день форумчане, нужна ваша помощь.
Суть задачи следующая необходимо суммировать определенные ячейки из нескольких книг в сводную.
Макрос должен:
1. открывать файлы в определенной папке указанной мной (например Продажи МП 2018_Курск)
2. запомнить значение в ячейке В5 (например оно 5)
3. закрыть текущий файл
4. открыть следующий файл в папке (например Продажи МП 2018_Самара)
5 к сохраненному значению В5 (оно 5) прибавить значение  в ячейке В5 нового открытого файла (например оно 10) и так по всем файлам.
6. Полученную сумму значений В5 (она будет 15) записать в сводный файл Продажи МП 2018 в ту же ячейка B5
7. повторить процедуру с п. 1 по п. 6 для ячейки с B6 по В28, в ячейке В29  записана формула она закрыта от редактирование ее изменять не нужно
8. далее перейти к ячейке В30 и повторить туже процедуру. и так до конца таблицы по столбцу B
Когда закончится столбец В перейти к столбцу С и повторить ту же процедуру и т.д.

Макрос на открытие файлов я нашел в интернете он в модуле 3, а вот с копированием проблема, много перечитал но ни чего не нашел подходящего
Помогите написать хотя-бы столбцы B и С, а я дальше сам по аналогии. ???


Записан

boa

  • Глобальный модератор
  • Постоялец
  • *****
  • Уважение: +26/-0
  • Оффлайн Оффлайн
  • Сообщений: 481
  • Доброта спасет мир...

Здравствуйте, Владимир
...повторить процедуру с п. 1 по п. 6 для ячейки с B6 по В28...

"...открыла сумочку, достала кошелочку, закрыла сумочку, открыла кошелочку, достала кошелек, закрыла кошелочку, открыла сумочку, положила туда кошелочку, закрыла сумочку... убил бы..."

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

Открыли файл - возьмите с него всю нужную информацию и только потом закрывайте.

Option Explicit

Sub FreeBooksOpen()
    Dim MyName As String
    Dim MyPath As String
    Dim iCol&, iRow&
    Dim importWB As Workbook, shIn As Worksheet, shOut As Worksheet
    Set shIn = ThisWorkbook.Sheets("продажи по наименованию")                   'лист куда будем копировать
   
    MyPath = "C:\Users\remont\Desktop\Макрос\От регионов\"
    MyName = Dir(MyPath & "*.xlsm")
    Do While MyName <> ""
        Set importWB = Excel.Application.Workbooks.Open(MyPath + MyName)    'книга откуда будем брать данные
        Set shOut = importWB.Sheets("продажи по наименованию")              'лист откуда будем брать данные
       
        ' и такой цикл по каждому непрерывному массиву данных, которые надо перенести
        For iRow = 5 To 28  'Range("B5:G28")
            For iCol = 2 To 7
                If shOut.Cells(iRow, iCol).Value <> 0 Then shIn.Cells(iRow, iCol).Value = shIn.Cells(iRow, iCol).Value + shOut.Cells(iRow, iCol).Value
            Next iCol
        Next iRow
'        ...
'        ...
       
        importWB.Close False    'закрываем обработанный файл без сохранения
        MyName = Dir            'переходим к следующему файлу
    Loop
End Sub
« Последнее редактирование: 01.06.2018, 17:14:30 от boa »
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

vikttur

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +46/-0
  • Онлайн Онлайн
  • Сообщений: 960

Работа с объектами листа медленная, лучше работать с массивами. Запись на лист - один раз после окончания суммирования.
ScreenUpdating = False - отключаем обновление экрана (моргание и задержки на перерисовку экрана)
DisplayAlerts = False - отключаем лишние вопросы (иначе - системные сообщения при работе с открываемыми книгами)
.Range("B5").Resize(lRw, lClmn) - задание размера копируемого диапазона. Можно ускорить на какие-то миллисекунды, если диапазон записывать явно, но при изменении размера копируемого диапазона придется править и эту строку.

Сохранение в книгу с макросом на лист "продажи по наименованию". Если нужна другая книга - дописать ее открытие.
Sub SumCopyData()
Dim aData(), aTemp()
Dim wBook As Workbook
Dim sPath As String, sFName As String
Dim i As Long, j As Long
Const lRw As Long = 24, lClmn As Long = 7 ' размер диапазона (строк, столбцов)
    ReDim aData(1 To lRw, 1 To lClmn) ' размерность по размеру диапазона
   
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
    sPath = ThisWorkbook.Path & "\Продажи МП 2018_Курск\"
    sFName = Dir(sPath & "*.xls*", vbDirectory)

    Do While sFName <> ""
        Set wBook = Workbooks.Open(Filename:=sPath & sFName) ' открыть книгу
       
        With wBook
            aTemp = .Sheets("продажи по наименованию").Range("B5").Resize(lRw, lClmn).Value ' диапазон исходных - в массив
            .Close
        End With
       
        For i = 1 To lRw
            For j = 1 To lClmn
                aData(i, j) = aData(i, j) + aTemp(i, j)
            Next j
        Next i

        sFName = Dir
    Loop
   
    ThisWorkbook.Sheets("продажи по наименованию").Range("B5").Resize(lRw, lClmn).Value = aData
   
    Set wBook = Nothing
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
End Sub
« Последнее редактирование: 01.06.2018, 19:54:40 от vikttur »
Записан

Владимир Попов

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 10

Спасибо большое за код, дописал макрос в модуль 2 все работает. Кому нужно обновленный файл в приложении ;D ::)
Записан

vikttur

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +46/-0
  • Онлайн Онлайн
  • Сообщений: 960

А сами найдете модуль в этом файле? :)
Записан

boa

  • Глобальный модератор
  • Постоялец
  • *****
  • Уважение: +26/-0
  • Оффлайн Оффлайн
  • Сообщений: 481
  • Доброта спасет мир...

А сами найдете модуль в этом файле? :)
sm_clap
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра
 



Темы без ответов

22.05.2018 11:38 Скрипт написать который допишет данные в файл 174
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 598
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 570
23.01.2018 13:46 Найти вероятность повторной покупки 581
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 783
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 850
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1086
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 2534
15.03.2017 15:45 автозамена картинок PowerPoint 1575
11.03.2017 13:43 Изменить нумерацию страниц 1807





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.095 секунд. Запросов: 103.