Hàm UDF dùng Dictionary với Key kết hợp nhiều cột chuỗi.

[Maika8008]

Cập nhật 11/06/2021:
File đính kèm có thêm hàm SumDicMMF có cách hoạt động giống SumDicMME nhưng thay vì lấy nguyên giá trị từng trường làm Key thì nó sẽ trích trong đó ra 1 giá trị dựa vào các hàm xử lý phổ biến Year, Month, Day, Left, Right, Mid.

Cú pháp test hàm có trong file đính kèm: SumDicMMF(Range("B3:F500"), [{"MONTH(1)","LEFT(3,3)","LEFT(4,3)"}], True, 5, 6), có nghĩa là nối Month của cột 1, Left cột 3 với 3 ký tự, Left cột 4 với 3 ký tự và cộng dồn cho cột 5, cột 6

Nếu muốn giữ nguyên giá trị của trường nào thì chỉ nhập số cột của trường đó, ví dụ: [{"MONTH(1)", 3, 4}]

Gõ công thức trực tiếp trên bảng tính: =UDF_ARRAYFORMULA(SumDicMMF(B3:G500;{"MONTH(1)"\"LEFT(3,3)"\"LEFT(4,3)"};TRUE;5;6))

File kèm chứa code hàm, code test và dữ liệu test hàm ở cuối bài.

Bài đăng ban đầu:
Ở chủ đề trước https://www.giaiphapexcel.com/diendan/threads/hàm-udf-dùng-dictionary-trích-lọc-một-cột-chuỗi-key-cho-nhiều-cột-giá-trị.155724/
hàm cho phép tổng hợp chỉ duy nhất 1 cột chuỗi thì hàm này có thể tùy ý kết hợp nhiều cột nối với nhau để trích lọc.
1/ Cú pháp hàm: SumDicMM(RgData, Columns, Header, ArrField()) với Columns là một mảng 1 chiều gồm 1 hoặc nhiều tên cột.
2/ Thủ tục chạy hàm:
Sub test2()
Dim arrKQ
arrKQ = SumDicMM(Range("E3:L85"), [{2,4}], True, 5, 7, 8) '
Range("N3").Resize(UBound(arrKQ, 1), UBound(arrKQ, 2)) = arrKQ
End Sub

3/ Code hàm:

Function SumDicMM(RgData As Range, Columns As Variant, Header As Boolean, ParamArray ArrField() As Variant) As Variant
Dim Dic1 As Object, msg As String, iKey As String, strSh As String
Dim arr() As Variant, TmpArr As Variant, arrTitle As Variant, XColumns As Variant, arrRsl As Variant
Dim ColNumKey As Variant, FColumn As Long, CPos As Long, ColNums As Long, FRow As Long
Dim irow As Long, i As Long, j As Long, k As Long, Rw As Long, Pos As Long
Dim ColDicKey As String

    strSh = RgData.Worksheet.Name
    If TypeName(RgData) <> "Range" Then Exit Function
    If Not IsArray(Columns) Then XColumns = Array(Columns) Else XColumns = Columns
    CPos = InStr(1, RgData.Address, ":")
    FRow = Range(Left(RgData.Address, CPos - 1)).Row
    ReDim arrTitle(1 To UBound(ArrField) + 2)
    Pos = InStr(2, RgData.Address, "$")
    Rw = Mid(RgData.Address, Pos + 1, CPos - Pos - 1)
    If Header Then
        Set RgData = Range(Left(RgData.Address, Pos) & Rw + 1 & Right(RgData.Address, Len(RgData.Address) - CPos + 1))
    End If
   
    FColumn = Range(Left(RgData.Address, CPos - 1)).Column
    ColNums = RgData.Columns.Count
'-------
    Dim N_Col As Long
    Dim vArr
    ColNumKey = XColumns
    For j = 1 To UBound(XColumns)
        If IsNumeric(XColumns(j)) Then
            msg = "S" & ChrW(7889) & " c" & ChrW(7897) & "t trong m" & ChrW(7843) & "ng ph" & ChrW(7843) & "i t" & ChrW(7915) & " 1 " & ChrW(273) & ChrW(7871) & "n " & ColNums & "."
            If ColNumKey(j) <= 0 Then Application.Assistant.DoAlert "Thông báo!", msg, 0, 4, 0, 0, 0: Exit Function
            ColNumKey(j) = XColumns(j)
        Else
            For N_Col = 1 To 256
                vArr = Split(Cells(1, N_Col).Address(True, False), "$")
                If vArr(0) = UCase(XColumns(j)) Then Exit For
            Next N_Col
            ColNumKey(j) = N_Col - FColumn + 1
            If ColNumKey(j) <= 0 Then
                msg = "C" & ChrW(7897) & "t '" & UCase(XColumns(j)) & "' n" & ChrW(7857) & "m ngoài vùng d" & ChrW(7919) & " li" & ChrW(7879) & "u." & vbNewLine
                msg = msg & "Vui l" & ChrW(242) & "ng nh" & ChrW(7853) & "p " & ChrW(273) & "úng tên c" & ChrW(7897) & "t " & ChrW(273) & ChrW(7875) & " t" & ChrW(7893) & "ng h" & ChrW(7907) & "p!"
                Application.Assistant.DoAlert "Thông báo!", msg, 0, 4, 0, 0, 0: Exit Function
            End If
        End If
    Next
'-------
    For k = 1 To UBound(XColumns)
        arrTitle(1) = arrTitle(1) & Sheets(strSh).Cells(Rw, FColumn + ColNumKey(k) - 1) & "-"
    Next
    arrTitle(1) = Left(arrTitle(1), Len(arrTitle(1)) - 1)
    Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = Sheets(strSh).Range(RgData.Address).Value
    If Header Then i = 1
    ReDim arr(1 To UBound(TmpArr, 1), 1 To ColNums)
    For j = 0 To UBound(ArrField)
   
        If ArrField(j) <= 0 Then msg = "S" & ChrW(7889) & " c" & ChrW(7897) & "t trong m" & ChrW(7843) & "ng ph" & ChrW(7843) & "i t" & ChrW(7915) & " 1 " & ChrW(273) & ChrW(7871) & "n " & ColNums & ".": _
        Application.Assistant.DoAlert "Thông báo!", msg, 0, 4, 0, 0, 0: Exit Function
        arrTitle(j + 2) = Sheets(strSh).Cells(Rw, ArrField(j) + FColumn - 1)
        For irow = 1 To UBound(TmpArr, 1)
            For k = 1 To UBound(XColumns)
                iKey = iKey & TmpArr(irow, ColNumKey(k)) & "|"
            Next
            iKey = Left(iKey, Len(iKey) - 1)
            If Not IsEmpty(iKey) And Not Dic1.Exists(iKey) Then
                i = i + 1
                Dic1.Add iKey, i
                arr(i, 1) = iKey
                arr(i, j + 2) = TmpArr(irow, ArrField(j))
            Else
                arr(Dic1.Item(iKey), j + 2) = arr(Dic1.Item(iKey), j + 2) + TmpArr(irow, ArrField(j))
            End If
            iKey = ""
        Next irow
    Next j
    If Header Then
        For j = 1 To UBound(ArrField) + 2
            arr(1, j) = arrTitle(j)
        Next
    End If
    ReDim Preserve arr(1 To UBound(arr, 1), 1 To UBound(ArrField) + 2)
    arrRsl = WorksheetFunction.Transpose(arr)
    ReDim Preserve arrRsl(1 To UBound(ArrField) + 2, 1 To i)
    arrRsl = WorksheetFunction.Transpose(arrRsl)
    SumDicMM = arrRsl
   
End Function

4/ Trong file đính kèm, tôi sử dụng code hỗ trợ hiện kết quả trả về của hàm trên trang tính của @Ngô Hải Đăng tại chủ đề này. Cú pháp viết trên bảng tính là:
=UDF_ARRAYFORMULA(SumDicMM(E3:L85;{2\4};TRUE;5;7;8))
với {2\4} là mảng gồm cột 2 và 4 của dữ liệu dùng để kết hợp làm key trích lọc. Nếu máy ai dùng kiểu dấu chấm thập phân, dấu phẩy phân cách đối số thì cú pháp là:
=UDF_ARRAYFORMULA(SumDicMM(E3:L85,{2,4},TRUE,5,7,8)).

 

[Maika8008]

Cập nhật: File đính kèm có thêm hàm SumDicMME với cú pháp giống hệt SumDicMM nhưng kết quả trả về được tách riêng từng cột của mỗi phần tử cấu thành Key

 

[Maika8008]

Cập nhật 11/06/2021:
File đính kèm có thêm hàm SumDicMMF có cách hoạt động giống SumDicMME nhưng thay vì lấy nguyên giá trị từng trường làm Key thì nó sẽ trích trong đó ra 1 giá trị dựa vào các hàm xử lý phổ biến Year, Month, Day, Left, Right, Mid.

Cú pháp test hàm có trong file đính kèm: SumDicMMF(Range("B3:F500"), [{"MONTH(1)","LEFT(3,3)","LEFT(4,3)"}], True, 5, 6), có nghĩa là nối Month của cột 1, Left cột 3 với 3 ký tự, Left cột 4 với 3 ký tự và cộng dồn cho cột 5, cột 6

Nếu muốn giữ nguyên giá trị của trường nào thì chỉ nhập số cột của trường đó, ví dụ: [{"MONTH(1)", 3, 4}]

Gõ công thức trực tiếp trên bảng tính: =UDF_ARRAYFORMULA(SumDicMMF(B3:G500;{"MONTH(1)"\"LEFT(3,3)"\"LEFT(4,3)"};TRUE;5;6))