Добрый день форумчане, нужна ваша помощь.
Суть задачи следующая необходимо суммировать определенные ячейки из нескольких книг в сводную.
Макрос должен:
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 и С, а я дальше сам по аналогии. ???
Здравствуйте, Владимир
Цитата: Владимир Попов от 01.06.2018, 13:30
...повторить процедуру с п. 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
Работа с объектами листа медленная, лучше работать с массивами. Запись на лист - один раз после окончания суммирования.
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
Спасибо большое за код, дописал макрос в модуль 2 все работает. Кому нужно обновленный файл в приложении ;D ::)
А сами найдете модуль в этом файле? :)
Цитата: vikttur от 04.06.2018, 17:16
А сами найдете модуль в этом файле? :)
sm_clap