Анна. У меня Excel 2003, поэтому у себя переделайте под свою версию.
Все файлы должны быть в одной папке. Макрос поочередно просматривает файлы и выбирает
нужные данные. Название файла заявок, например Заявки_маркетинг.xls и имя листа, с которого
идет сбор данных, должны совпадать (Заявки_маркетинг)
| Код |
|---|
Sub Sbor()
Dim iSumma As Double
Dim iShName As String
Dim iDate As Date
Dim FoundDate As Range
Dim FAdr As String
Dim n As Integer
Dim iStolb As Integer
Dim Заявки As Workbook 'текущая книга
Dim ЗаявкиSht As Worksheet 'лист в файле Заявки
Dim iTempFileName As String 'имя поочерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRow As Long 'последняя заполненная строка в столбце A
Dim iLastRowTemp As Long 'последняя заполненная строка в открыв.файле
Dim iNumFiles As Long 'количество открываемых файлов
With Application
.ScreenUpdating = False
.Calculation = xlManual
Set Заявки = ThisWorkbook 'книга где макрос
Set ЗаявкиSht = Заявки.Sheets("сбор данных") 'лист в этой книге
iLastRow = ЗаявкиSht.Cells(Rows.Count, 1).End(xlUp).Row
Range("C2:E" & iLastRow).ClearContents 'очищаем диапазон от данных
iPath = Заявки.Path & "\"
iTempFileName = Dir(iPath & "*.xls") 'считываем название файла из папки где и книга с макросом
Do While iTempFileName <> ""
If iTempFileName <> Заявки.Name Then 'если это не книга с макросом
' открываем очередную книгу в режиме только чтение
With .Workbooks.Open _
(Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
iShName = Split(iTempFileName, ".")(0)
iNumFiles = iNumFiles + 1
With Sheets(iShName)
iLastRowTemp = .Cells(Rows.Count, 8).End(xlUp).Row
iDate = ЗаявкиSht.Cells(3, 2)
Select Case iShName
Case "Заявки_закупки"
iStolb = 3
Case "Заявки_маркетинг"
iStolb = 4
Case "Заявки_СУП"
iStolb = 5
End Select
ЗаявкиSht.Cells(2, iStolb) = WorksheetFunction.CountA(.Range("H2:H" & iLastRowTemp))
ЗаявкиSht.Cells(4, iStolb) = WorksheetFunction.Sum(.Range("H2:H" & iLastRowTemp))
Set FoundDate = .Columns(1).Find(iDate, , xlFormulas, xlWhole)
If Not FoundDate Is Nothing Then
FAdr = FoundDate.Address
n = 0
iSumma = 0
Do
iSumma = iSumma + .Cells(FoundDate.Row, 8)
n = n + 1
Set FoundDate = .Columns(1).FindNext(FoundDate)
Loop While FoundDate.Address <> FAdr
ЗаявкиSht.Cells(3, iStolb) = n
ЗаявкиSht.Cells(5, iStolb) = iSumma
End If
End With
.Close saveChanges:=False 'закрываем очередную книгу без сохранения
End With
End If
iTempFileName = Dir 'считываем название следующего в папке файла
Loop
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
MsgBox "Информация собрана из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub
|
Макрос привяжите к кнопке Собрать данные
Пробуйте! Удачи!
