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
