Страницы: 1
RSS
Сборка сумм и уникальных значений с данных со всех листов книги Excel в одну таблицу
 

Добрый день, знатоки!

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

Необходимо в листе «отчет» сделать как бы сводную таблицу со всех листов файла, а именно получить уникальные коды клиентов из всех листов по месяцам и на какую сумму товаров они получили. Можно слить все данные в одну таблицу и делать из них сводную, но необходимо, что бы это делалось автоматически.

То есть, чтобы в листе «Отчет», в столбце «В» подтянулись все уникальные коды со всех месяцев (столбцы «В» в других листах, а в столбце «С» общая сумма помощи, которую получает клиент в каждом месяцу (столбцы CY).

Прошу вашей помощи.

Огромное спасибо!  

 
Код
Sub Собрать()
    Const RESULT_SHEET_NAME = "ОТЧЕТ"

    Dim wb As Workbook
    Set wb = ActiveWorkbook

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If sh.Name <> RESULT_SHEET_NAME Then
            CollectFromSheet sh, dic, 6, [B1].Column, [CY1].Column
        End If
    Next
    Dim arr As Variant
    arr = DicToArr(dic)
    PrintResult wb.Sheets(RESULT_SHEET_NAME).Range("B6"), arr
End Sub

Private Function DicToArr(dic As Object) As Variant
    Dim arr As Variant
    If dic.Count = 0 Then
        ReDim arr(1 To 1, 1 To 2)
    Else
        ReDim arr(1 To dic.Count, 1 To 2)
        Dim brr As Variant
        brr = Array(dic.Keys(), dic.Items())
        Dim yy As Long
        Dim xx As Long
        For yy = 1 To UBound(arr, 1)
            For xx = 1 To UBound(arr, 2)
                arr(yy, xx) = brr(xx - 1)(yy - 1)
            Next
        Next
    End If
    DicToArr = arr
End Function

Private Sub PrintResult(rn As Range, arr As Variant)
    Application.EnableEvents = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    rn.Resize(rn.Parent.UsedRange.Rows.Count, UBound(arr, 2)).ClearContents
    rn.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
    Application.Calculation = Application_Calculation
    Application.EnableEvents = True
End Sub

Private Sub CollectFromSheet(sh As Worksheet, dic As Object, y1 As Long, xID As Long, xVa As Long)
    Dim arr As Variant
    Dim yy As Long
    Dim dd As Double
    Dim ss As String
    With sh
        yy = .Cells(.Rows.Count, xID).End(xlUp).Row
        If yy >= y1 Then
            Dim aID As Variant
            Dim aVa As Variant
            aID = .Cells(1, xID).Resize(yy)
            aVa = .Cells(1, xVa).Resize(yy)
            For yy = y1 To UBound(aID, 1)
                ss = ""
                dd = 0
                On Error Resume Next
                ss = aID(yy, 1)
                dd = aVa(yy, 1)
                On Error GoTo 0
                If dd <> 0 Then
                    If ss <> "" Then
                        dic.Item(ss) = dic.Item(ss) + dd
                    End If
                End If
            Next
        End If
    End With
End Sub
Страницы: 1
Наверх