Hàm UDF dùng Dictionary trích lọc một cột chuỗi (Key) cho nhiều cột giá trị.

[Maika8008]

Rảnh rỗi tự nhiên nghĩ đến việc dùng ParamArray để làm một việc gì đó có ích chút thì chợt nhớ đến Dictionary. Đó là hoàn cảnh xuất thân của cái hàm này .

Hàm có thể tổng hợp giá trị cho nhiều cột số (nhiều bao nhiêu thì tùy thuộc vào giới hạn của ParamArray) dựa vào 1 cột chuỗi được chọn làm key cho Dictionary. Kết quả trả về là một mảng [Arr, x, y], trong đó:
- Arr là mảng kết quả của việc trích lọc bằng Dictionary.
- x là số dòng của mảng Arr
- y là số cột của Arr

1/ Cú pháp hàm: SumDicM(RgData, ColDicKey, Header, ArrField())
trong đó:
- RgData là vùng ô chứa dữ liệu gốc, ví dụ: Range("Range("E3:L85").
- ColDicKey là cột chuỗi làm key cho Dictionary để nhóm tổng (Group), viết rõ tên cột, VD: "h" hay "H" đều được. Nếu nhập giá trị số sẽ được hiểu là số cột trong mảng dữ liệu.
- Header nhận giá trị TRUE hoặc FALSE để kết quả chép ra có chứa hay không chứa tiêu đề.
- ArrField() là mảng chứa các cột cần cộng giá trị dựa vào cột ColDicKey. Cứ viết trực tiếp, mỗi cột cách nhau bởi dấu phẩy. Viết bằng chữ cái tên cột hoặc bằng số cột trong mảng cũng được nhưng phải nhất quán kẻo nhầm 2 phần tử nhưng trỏ cùng cột.

2/ Để chạy hàm cần viết 2 câu lệnh như sau:
arrKQ = SumDicM(Range("E3:L85"), "h", True, 5, 7, 8)
Range("##$$").Resize(arrKQ(1), arrKQ(2)) = arrKQ(0)

- arrKQ là mảng 1 chiều nhận kết quả trả về của hàm
- Range("##$$") là ô đầu tiên trên bảng tính nơi chép kết quả trả về.
- arrKQ(1) là số dòng của mảng
- arrKQ(2) là số cột của mảng
- arrKQ(0) là mảng kết quả đã qua trích lọc.

Code và dữ liệu trong File đính kèm.

Option Explicit

Sub test()
Dim arrKQ
    arrKQ = SumDicM(Range("E3:L85"), 4, True, "I", 7, 8) '
    Range("n3").Resize(arrKQ(1), arrKQ(2)) = arrKQ(0)
End Sub

Function SumDicM(RgData As Range, ColDicKey As String, Header As Boolean, ParamArray ArrField() As Variant) As Variant
Dim Dic1 As Object, msg As String
Dim arr() As Variant, TmpArr As Variant, arrTitle As Variant
Dim ColNumKey As Long, FColumn As Long, CPos As Long, ColNums As Long, FRow As Long, ColField As Long
Dim irow As Long, i As Long, j As Long, Rw As Long, Pos As Long

    If TypeName(RgData) <> "Range" Then Exit Function
    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
   
    If IsNumeric(ColDicKey) = False Then
        For N_Col = 1 To 256
            vArr = Split(Cells(1, N_Col).Address(True, False), "$")
            If vArr(0) = UCase(ColDicKey) Then Exit For
        Next N_Col
        ColNumKey = N_Col - FColumn + 1
        If ColNumKey <= 0 Then
            msg = "C" & ChrW(7897) & "t '" & UCase(ColDicKey) & "' 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
    Else
        If ColDicKey <= 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
        ColNumKey = ColDicKey
    End If
'-------
    arrTitle(1) = Cells(Rw, FColumn + ColNumKey - 1)
    Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = RgData.Value
    If Header Then i = 1
    ReDim arr(1 To UBound(TmpArr, 1), 1 To ColNums)
    For j = 0 To UBound(ArrField)
       
        If IsNumeric(ArrField(j)) = False Then
            For N_Col = 1 To 256
                vArr = Split(Cells(1, N_Col).Address(True, False), "$")
                If vArr(0) = UCase(ArrField(j)) Then Exit For
            Next N_Col
            ColField = N_Col - FColumn + 1
            If ColField <= 0 Then
                msg = "C" & ChrW(7897) & "t '" & UCase(ArrField(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
        Else
            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
            ColField = ArrField(j)
        End If
   
        arrTitle(j + 2) = Cells(Rw, ColField + FColumn - 1)
        For irow = 1 To UBound(TmpArr, 1)
            If Not IsEmpty(TmpArr(irow, ColNumKey)) And Not Dic1.Exists(TmpArr(irow, ColNumKey)) Then
                i = i + 1
                Dic1.Add TmpArr(irow, ColNumKey), i
                arr(i, 1) = TmpArr(irow, ColNumKey)
                arr(i, j + 2) = TmpArr(irow, ColField)
            Else
                arr(Dic1.Item(TmpArr(irow, ColNumKey)), j + 2) = arr(Dic1.Item(TmpArr(irow, ColNumKey)), j + 2) + TmpArr(irow, ColField)
            End If
        Next irow
    Next j
    If Header Then
        For j = 1 To UBound(ArrField) + 2
            arr(1, j) = arrTitle(j)
        Next
    End If
    SumDicM = Array(arr, i, UBound(ArrField) + 2)
   
End Function

 

[Maika8008]

Cập nhật:
Kết quả trả về của hàm là mảng dữ liệu trích lọc (tức là = arrKQ(0) ở bài #1), tiện lợi hơn khi gọi hàm từ một hàm/thủ tục khác.

Code để chạy hàm:
Sub test()
Dim arrKQ
arrKQ = SumDicM(Range("E3:L85"), 4, True, 5, 7, 8) '
Range("N3").Resize(UBound(arrKQ, 1), UBound(arrKQ, 2)) = arrKQ
End Sub

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

    If TypeName(RgData) <> "Range" Then Exit Function
    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
    
    If IsNumeric(ColDicKey) = False Then
        For N_Col = 1 To 256
            vArr = Split(Cells(1, N_Col).Address(True, False), "$")
            If vArr(0) = UCase(ColDicKey) Then Exit For
        Next N_Col
        ColNumKey = N_Col - FColumn + 1
        If ColNumKey <= 0 Then
            msg = "C" & ChrW(7897) & "t '" & UCase(ColDicKey) & "' 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
    Else
        If ColDicKey <= 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
        ColNumKey = ColDicKey
    End If
'-------
    arrTitle(1) = Cells(Rw, FColumn + ColNumKey - 1)
    Set Dic1 = CreateObject("Scripting.Dictionary")
    TmpArr = RgData.Value
    If Header Then i = 1
    ReDim arr(1 To UBound(TmpArr, 1), 1 To ColNums)
    For j = 0 To UBound(ArrField)
        
        If IsNumeric(ArrField(j)) = False Then
            For N_Col = 1 To 256
                vArr = Split(Cells(1, N_Col).Address(True, False), "$")
                If vArr(0) = UCase(ArrField(j)) Then Exit For
            Next N_Col
            ColField = N_Col - FColumn + 1
            If ColField <= 0 Then
                msg = "C" & ChrW(7897) & "t '" & UCase(ArrField(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
        Else
            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
            ColField = ArrField(j)
        End If
    
        arrTitle(j + 2) = Cells(Rw, ColField + FColumn - 1)
        For irow = 1 To UBound(TmpArr, 1)
            If Not IsEmpty(TmpArr(irow, ColNumKey)) And Not Dic1.Exists(TmpArr(irow, ColNumKey)) Then
                i = i + 1
                Dic1.Add TmpArr(irow, ColNumKey), i
                arr(i, 1) = TmpArr(irow, ColNumKey)
                arr(i, j + 2) = TmpArr(irow, ColField)
            Else
                arr(Dic1.Item(TmpArr(irow, ColNumKey)), j + 2) = arr(Dic1.Item(TmpArr(irow, ColNumKey)), j + 2) + TmpArr(irow, ColField)
            End If
        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)
    
    SumDicM = arrRsl
End Function

 

[Maika8008]

Cập nhật 2: Sửa code để nhận được vùng dữ liệu trên sheet khác với sheet nhập công thức

Function SumDicM(RgData As Range, ColDicKey As String, Header As Boolean, ParamArray ArrField() As Variant) As Variant
Dim Dic1 As Object, msg As String, strSh As String
Dim arr() As Variant, TmpArr As Variant, arrTitle As Variant, arrRsl As Variant
Dim ColNumKey As Long, FColumn As Long, CPos As Long, ColNums As Long, FRow As Long, ColField As Long
Dim irow As Long, i As Long, j As Long, Rw As Long, Pos As Long
    
    strSh = RgData.Worksheet.Name
    If TypeName(RgData) <> "Range" Then Exit Function
    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
    
    If IsNumeric(ColDicKey) = False Then
        For N_Col = 1 To 256
            vArr = Split(Cells(1, N_Col).Address(True, False), "$")
            If vArr(0) = UCase(ColDicKey) Then Exit For
        Next N_Col
        ColNumKey = N_Col - FColumn + 1
        If ColNumKey <= 0 Then
            msg = "C" & ChrW(7897) & "t '" & UCase(ColDicKey) & "' 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
    Else
        If ColDicKey <= 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
        ColNumKey = ColDicKey
    End If
'-------
    arrTitle(1) = Sheets(strSh).Cells(Rw, FColumn + ColNumKey - 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 IsNumeric(ArrField(j)) = False Then
            For N_Col = 1 To 256
                vArr = Split(Cells(1, N_Col).Address(True, False), "$")
                If vArr(0) = UCase(ArrField(j)) Then Exit For
            Next N_Col
            ColField = N_Col - FColumn + 1
            If ColField <= 0 Then
                msg = "C" & ChrW(7897) & "t '" & UCase(ArrField(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
        Else
            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
            ColField = ArrField(j)
        End If
    
        arrTitle(j + 2) = Sheets(strSh).Cells(Rw, ColField + FColumn - 1)
        For irow = 1 To UBound(TmpArr, 1)
            If Not IsEmpty(TmpArr(irow, ColNumKey)) And Not Dic1.Exists(TmpArr(irow, ColNumKey)) Then
                i = i + 1
                Dic1.Add TmpArr(irow, ColNumKey), i
                arr(i, 1) = TmpArr(irow, ColNumKey)
                arr(i, j + 2) = TmpArr(irow, ColField)
            Else
                arr(Dic1.Item(TmpArr(irow, ColNumKey)), j + 2) = arr(Dic1.Item(TmpArr(irow, ColNumKey)), j + 2) + TmpArr(irow, ColField)
            End If
        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)
    
    SumDicM = arrRsl
End Function