Макрос-павук для збору даних з різних файлів

В даній статті розглянемо приклад макросу, який може шукати дані по багатьом робочим книгам та записувати вибрану інформацію в окремий файл-звіт. Для цього відкрийте свою книгу, перейдіть у Visual Basic Editor (Alt+F11), додайте новий бланк модуля (Insert - Module) і скопіюйте цей текст макроса туди:

 Sub Report_file()
'moonexcel.com.ua
Application.ScreenUpdating = False 'відключаємо оновлення екрану

    Set report = Workbooks("Report.xlsb").Worksheets(1)
    find_field = report.[a1]
    
    'викликаємо діалог вибору файлів для імпорту
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Виберіть файли!")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не вибрано жодного файлу!"
        Exit Sub
    End If
    
    'перебираємо по черзі всі вибрані файли
    m = 1
    While m <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(m))
        Set importWS = importWB.Worksheets(1)
    
        'перебиоаємо комірки "шапки"
        For Each cell2 In report.Range(report.Cells(1, 2), report.Cells(1, report.UsedRange.Columns.Count))
            On Error Resume Next: Err.Clear
            'шукаємо значення у відкритій книзі
            tr = importWS.UsedRange.Find(find_field).Row
            tc = importWS.UsedRange.Find(find_field).Column
            x = importWS.Range(importWS.Cells(tr, tc), importWS.Cells(20000, tc)).Find(report.Cells(m + 1, 1).Value).Row
            y = importWS.UsedRange.Find(cell2.Value).Column
            'переносимо знайдені значення у файл-звіт
            report.Cells(m + 1, cell2.Column).Value = importWS.Cells(x, y).Value
        Next
        
        importWB.Close savechanges:=False
        m = m + 1
    Wend
         
Application.ScreenUpdating = True
    
End Sub

Після цього можете повернутися в Excel та запустити наш макрос через меню Tools - Macro - Macros (Alt+F8).

ОНЛАЙН СЕРВІСИ