Добрый день. Просьба помочь в построение следующий формулы. Есть клиенты, которые тратят по определенным категориям, требуется извлечь по каждому клиенту 4 самые высоко затратные категории.
Sub Макрос1()
Dim lr As Long, n As Long, m As Long, arr1 As Variant, arr2 As Variant, y As Variant
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
arr1 = ActiveSheet.ListObjects("Лист13").DataBodyRange
For n = LBound(arr1) To UBound(arr1)
If Not dic.exists(arr1(n, 1)) Then
Set dic(arr1(n, 1)) = CreateObject("System.Collections.ArrayList")
Set dic1(arr1(n, 1)) = CreateObject("Scripting.Dictionary")
End If
dic(arr1(n, 1)).Add arr1(n, 3)
If Not dic1(arr1(n, 1)).exists(arr1(n, 3)) Then
dic1(arr1(n, 1)).Add arr1(n, 3), n
Else
dic1(arr1(n, 1)).Item(arr1(n, 3)) = dic1(arr1(n, 1)).Item(arr1(n, 3)) & "|" & n
End If
Next n
ReDim arr2(1 To dic.Count, 1 To 5)
n = 1
For Each y In dic
dic(y).Sort
dic(y).Reverse
m = 2
arr2(n, 1) = y
For Each x In dic(y)
arr2(n, m) = arr1(Split(dic1(y).Item(x), "|")(0), 2)
If InStr(dic1(y).Item(x), "|") > 0 Then dic1(y).Item(x) = Mid(dic1(y).Item(x), InStr(dic1(y).Item(x), "|") + 1)
m = m + 1
If m > 5 Then Exit For
Next x
n = n + 1
Next y
Cells(2, 13).Resize(UBound(arr2), 5) = arr2
End Sub