Lọc dữ liệu nhiều điều kiện (1 người xem)

[Nguyễn Duy Tuân]

Mình có file cần lấy dữ liệu như file kèm , bạn xem giúp . cám ơn bạn nhiều nhiều nhé

Bài của bạn tôi đã viết thành một hàm mảng động, chạy tự co giãn dòng và cột theo dữ liệu phát sinh. Chỉ cần cài Add-in A-Tools như bài trước mở file này là chạy được.

https://www.facebook.com/video.php?v=10223764720361277

Download file: https://drive.google.com/file/d/1dakagNxO_nm4EFdNHV4LzPHTBzeYgv9X/view?usp=sharing

Mã nguồn tạo hàm trả về mảng động với yêu cầu bài toán trên:

Function TongVaTach(ByVal SQL As String, Optional ByVal Options As String = "")
    Dim fa As New BSFormulaArray
    Dim fi As New BSFormulaInfo
    Dim arr
    If fa.Begin Then
        fi.FunctionName = "TongVaTach"
        'Save parameters for using later. (in CallbackResult)
        fi.PARAMS = Array(SQL, Options)
        fi.OptionStr = Options
        fi.lpfnOnGetResult = GetCallbackFunction(AddressOf CallbackResult)
        TongVaTach = fa.Add(fi, arr)
    Else
        TongVaTach = fa.Result
    End If
    Set fi = Nothing
    Set fa = Nothing
End Function

Function CallbackResult(ByVal fi As AddinATools.IBSFormulaInfo, _
                        ByVal FmlRange As Range, _
                        ByVal FmlState As AddinATools.BSFmlState, _
                        AResult As Variant) As Boolean
    If FmlState = fsOnCalc Then
        'fi.PARAMS(0) is SQL input from function "TongVaTach"
        'fi.PARAMS(1) is OPTIONs input from function "TongVaTach"
        AResult = GetArr(fi.PARAMS(0), fi.PARAMS(1))
        CallbackResult = True
    ElseIf FmlState = fsBeforeUpdate Then
        'Do something
    End If
End Function

Private Function GetArr(ByVal SQL As String, Optional ByVal Options As String = "")
    Dim bf As New BSFunctions
    Dim arr, RST As Object, fa As New BSFormulaArray
    Dim lRow&, uRow&, lCol&, uCol&, I&, J&, MaxCols&, n&
    Set RST = fa.ExecuteQuery(SQL, Options)
    arr = fa.GetArrayFromRecordset(RST)
    'Convert array Rows-> Cols and assign value ...
    lRow = LBound(arr, 2): uRow = UBound(arr, 2)
    lCol = LBound(arr, 1): uCol = UBound(arr, 1)
    ReDim Arr2(uRow, uCol * 2)
    MaxCols = 0
    For I = lRow + 1 To uRow
        Arr2(I, lCol) = arr(lCol, I)
        n = 0
        For J = lCol + 1 To uCol
            If arr(J, I) <> "" Then
                n = n + 2
                Arr2(I, n - 1) = arr(J, I) 'Sl
                Arr2(I, n) = IIf(arr(J, lCol) = "", "Blank", arr(J, lCol)) 'Ngay ve
            End If
        Next J
        MaxCols = WorksheetFunction.Max(MaxCols, n)
    Next I
    'Write header row
    Dim MA, Sl, NGAY_VE
    n = 0
    Sl = Application.Range("SL").Value2
    NGAY_VE = Application.Range("NGAY_VE").Value2
    MA = Application.Range("MA").Value2
    Arr2(lRow, lCol) = MA
    For J = lCol + 1 To MaxCols Step 2
        n = n + 1
        Arr2(lRow, J) = Sl
        Arr2(lRow, J + 1) = NGAY_VE & " " & n
    Next J
    ReDim Arr3(uRow, MaxCols)
    For I = lRow To uRow
        For J = lCol To MaxCols
            Arr3(I, J) = Arr2(I, J)
            If Arr3(I, J) = 0 Then
                Arr3(I, J) = ""
            End If
        Next J
    Next I
    GetArr = Arr3
    RST.Close 'Free memory
    Erase arr
    Erase Arr2
    Set RST = Nothing
    Set bf = Nothing
    Set fa = Nothing
End Function