Тема создана для справки в связи с участившимися вопросами. Тема НЕ о UDF (макрофункции листа) а о макросе со вставкой. Тестируйте, кто может/хочет — делать демонстрационный стенд пока нет времени. Если кто сделает нормальный - добавлю.
Описание, Файл и Код
Описание
• Макрос представляет собой функцию с параметрами для вызова из VBA. • Макрос ЗАМЕНЯЕТ ключи в переданном диапазоне (1ый аргумент) на СЧЁТ/СУММУ/МАКС/СЦЕПКУ по этим ключам. • МИН/СРЕД и прочие функции являются косвенными и вытекают из вышеуказанных, поэтому отдельно развивать и усложнять не стал. • Сцепка может быть только уникальных значений UniqJoin=True (по умолчанию нет). • Ключи сравниваются в текстовом виде, то есть 1 и "1" это один и тот же ключ. • Регистр ключей можно игнорировать (по умолчанию нет). • ОШИБКИ и ПУСТЫЕ в качестве КЛЮЧЕЙ или ЗНАЧЕНИЙ для агрегации — ПРОПУСКАЮТСЯ.
Option Base 1 ' Arrays start from 1: Dim arr(2,2) == Dim arr(1 To 2, 1 To 2)
Option Explicit ' Require declaration of all variables
Option Private Module ' Visibility of macro in MacroWindow (Alt+F8)
'====================================================================================================
'====================================================================================================
' Function return count of the changed cells or "-1" if Error
Function AggregateByCriteria(rngInsert As Range, TypeGet$, rng1ColCrit As Range, Optional rng1ColGet As Range, Optional CaseIgnore As Boolean, Optional UniqJoin As Boolean) As Long ' TypeGet: "count", "sum", "max", "join"
Dim dIns As New Dictionary, dFind As New Dictionary ' or «Dim dIns As Object (and others…): Set dIns=CreateObject("Scripting.Dictionary")» — if lib "Microsoft Scripting Runtime" NOT in Tools—>References
Dim fCount As Boolean, fSum As Boolean, fMax As Boolean, fJoin As Boolean
Dim x, aCrit, aGet, aAreas(), aColl(), aOne(1, 1)
Dim t!, a&, r&, c&, p&, nI&, nF&, AC&, f As Boolean
Const sepJoin$ = "|•$%@#•|"
t = Timer
AggregateByCriteria = -1
Select Case LCase$(TypeGet)
Case "count": fCount = True
Case "sum": fSum = True: f = rng1ColGet Is Nothing
Case "max": fMax = True: f = rng1ColGet Is Nothing
Case "join": fJoin = True: f = rng1ColGet Is Nothing
Case Else: MsgBox "TypeGet «" & TypeGet & "» doesn't Exists!" & vbLf & "Only «Count», «Sum», «Max» or «Join»!", vbCritical, Format$(Timer - t, "0.00 sec"): Exit Function
End Select
If f Then MsgBox "Missing of «rng1ColGet» (RangeOneCol with Values to Aggregate)!", vbCritical, Format$(Timer - t, "0.00 sec"): Exit Function
ReDim aAreas(rngInsert.Areas.Count)
For a = 1 To UBound(aAreas) ' 1. Collect keys, need to search -------------------------
aCrit = rngInsert.Areas(a).Value ' Area.Value to Array2D
If Not IsArray(aCrit) Then aOne(1, 1) = aCrit: aCrit = aOne ' If one cell, transform with temp Array2D
For c = 1 To UBound(aCrit, 2)
For r = 1 To UBound(aCrit, 1)
If IsError(aCrit(r, c)) Then GoTo nx1 ' Skip error
If Len(aCrit(r, c)) = 0 Then GoTo nx1 ' Skip empty
If CaseIgnore Then aCrit(r, c) = LCase$(aCrit(r, c)) Else aCrit(r, c) = CStr(aCrit(r, c)) ' Key to text
x = dIns(aCrit(r, c)) ' Fill dic with only Keys
nx1: Next r
Next c
aAreas(a) = aCrit ' Save Area.Value to Array1D of Arrays2D
Next a
nI = dIns.Count: If nI = 0 Then MsgBox "There is NO any Currient Keys to Search in the Insert Range!", vbCritical, Format$(Timer - t, "0.00 sec"): Exit Function
ReDim aColl(dIns.Count) ' Array1D for collecting
aCrit = rng1ColCrit.Value2 ' Array2D of Values to Search [Criterias]
If Not fCount Then aGet = rng1ColGet.Value2 ' Array2D of Values to Collect
For r = 1 To UBound(aCrit, 1) ' 2. Collect Values by Keys -------------------------------
If IsError(aCrit(r, 1)) Then GoTo nx2
If Not fCount Then If IsError(aGet(r, 1)) Then GoTo nx2
If Len(aCrit(r, 1)) = 0 Then GoTo nx2
If Not fCount Then If Len(aGet(r, 1)) = 0 Then GoTo nx2
If CaseIgnore Then aCrit(r, c) = LCase$(aCrit(r, c)) Else aCrit(r, c) = CStr(aCrit(r, c))
If Not dIns.Exists(aCrit(r, c)) Then GoTo nx2 ' Check Current Criteria in dic of Searching Keys
If dFind.Exists(aCrit(r, c)) Then
a = dFind(aCrit(r, c))
If fCount Then
aColl(a) = aColl(a) + 1
ElseIf fSum Then
If IsNumeric(aGet(r, 1)) Then aGet(r, 1) = --aGet(r, 1) Else GoTo nx2
If Len(aColl(a)) = 0 Then aColl(a) = aGet(r, 1)
aColl(a) = aColl(a) + aGet(r, 1)
ElseIf fMax Then
If IsNumeric(aGet(r, 1)) Then aGet(r, 1) = --aGet(r, 1) Else GoTo nx2
If Len(aColl(a)) = 0 Then aColl(a) = aGet(r, 1): GoTo nx2
If aColl(a) < aGet(r, 1) Then aColl(a) = aGet(r, 1)
Else
If InStr(aGet(r, 1), sepJoin) Then GoTo erSep
aColl(a) = aColl(a) & sepJoin & aGet(r, 1)
End If
Else
nF = nF + 1: dFind.Add aCrit(r, c), nF
If fCount Then
aColl(nF) = 1
ElseIf fSum Or fMax Then
If IsNumeric(aGet(r, 1)) Then aColl(nF) = --aGet(r, 1)
Else
If InStr(aGet(r, 1), sepJoin) Then GoTo erSep
aColl(nF) = aGet(r, 1)
End If
End If
nx2:
Next r
dIns.RemoveAll
nF = dFind.Count: AggregateByCriteria = nF
If nF = 0 Then MsgBox "Can't Find any Keys of Insert Range in «rng1ColCrit» (RangeOneCol with Criterias)!", vbCritical, "AggregateByCriteria": Exit Function
Application.ScreenUpdating = False
AC = Application.Calculation: Application.Calculation = xlCalculationManual
For a = 1 To UBound(aAreas) ' 3. Fill rngIns. Change Keys by Aggregate Values ---------
aCrit = aAreas(a)
For c = 1 To UBound(aCrit, 2)
For r = 1 To UBound(aCrit, 1)
If IsError(aCrit(r, c)) Then GoTo nx3
If Len(aCrit(r, c)) = 0 Then GoTo nx3
If Not dFind.Exists(aCrit(r, c)) Then GoTo nx3
If Not fJoin Then aCrit(r, c) = dFind(aCrit(r, c)): GoTo nx3
If Not UniqJoin Then aCrit(r, c) = dFind(aCrit(r, c)): GoTo nx3
For Each x In Split(dFind(aCrit(r, c)), sepJoin)
x = dIns(x)
Next x
aCrit(r, c) = Join(dIns.Keys, sepJoin)
dIns.RemoveAll
nx3: Next r
Next c
rngInsert.Areas(a).Value = aCrit
Next a
Application.Calculation = AC
Application.ScreenUpdating = True
Exit Function
erSep: MsgBox "Values to Join can't exists the Separator «" & sepJoin & "»!", vbCritical, "AggregateByCriteria"
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄