Ứng dụng Class Module để viết hàm UDF_ArrayFormula

Chia sẻ bởi:hands

★★★★★

‹ Cách sử dung hàm Countif trong VBA Anh/chị giúp e tách cột TK của... ›

Quảng cáo

Ứng dụng Class Module để viết hàm UDF_ArrayFormula

Hàm này sẽ hỗ trợ hiển thị kết quả là mảng trên trang tính. Các phiên bản Excel đã hỗ trợ sẵn việc hiển thị mảng thì không cần dùng hàm này. Một số công thức phải gõ Ctrl+Shitf+Enter tại ô chứa công thức thì mới hiện thị kết quả.

Đầu tiên là tạo Class Module tên UDSF.

Option Explicit

Private cParam As New Collection
Private cCaller As New Collection
Private fCalc As Boolean

Private WithEvents Worksheet As Excel.Worksheet
Private WithEvents Workbook As Excel.Workbook

Sub Link(ParamArray iSubParam())
  If fCalc Then Exit Sub
  If TypeName(Application.Caller) <> "Range" Then Exit Sub
  cCaller.Add Application.Caller
  cParam.Add iSubParam
  Set Worksheet = Application.Caller.Worksheet
  If Workbook Is Nothing Then Set Workbook = Application.ThisWorkbook
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Application.CountA(Target) = 0 Then
    Set Workbook = Nothing
    Dim r As Range, aX
    Set r = Target.Find("*", , xlComments)
    On Error Resume Next
    While Not r Is Nothing
      aX = Split(r.Comment.Text, "$")
      r.Resize(aX(1), aX(2)) = Empty
      r.Comment.Delete
      Set r = Target.Find("*", , xlComments)
    Wend
    Set Workbook = Application.ThisWorkbook
  End If
End Sub

Private Sub Worksheet_Calculate()
  Set Worksheet = Nothing
  Set Workbook = Nothing
  fCalc = True
  On Error GoTo Reset
  While cParam.Count > 0
    Application.Run cParam(1)(0), cParam(1), cCaller(1)
    cCaller.Remove 1
    cParam.Remove 1
  Wend
Reset:
  Set Workbook = Application.ThisWorkbook
  Set cParam = Nothing
  Set cCaller = Nothing
  fCalc = False
End Sub

Tiếp theo là tạo 1 Module để sử dụng Class Module này.

Option Explicit

Public oUDSF As New UDSF

Function UDF_ARRAYFORMULA(iArray)
  UDF_ARRAYFORMULA = iArray
  oUDSF.Link "UDS_ARRAYFORMULA", UDF_ARRAYFORMULA
End Function

Private Sub UDS_ARRAYFORMULA(iParam, iCaller As Range)
  Dim sF$: sF = iCaller.Formula
  Dim fA As Boolean: fA = iCaller.HasArray
  Dim x&, y&, aX: x = 1: y = -1
  On Error Resume Next
  x = UBound(iParam(1)) - LBound(iParam(1)) + 1
  y = UBound(iParam(1), 2) - LBound(iParam(1), 2) + 1
  On Error GoTo 0
  If y = -1 Then y = x: x = 1
  If Not iCaller.Comment Is Nothing Then
    aX = Split(iCaller.Comment.Text, "$")
    iCaller.Resize(aX(1), aX(2)) = Empty
    iCaller.Comment.Delete
  End If
  iCaller.Resize(x, y) = iParam(1)
  iCaller.AddComment "AF$" & x & "$" & y
  iCaller.Comment.Shape.Height = 16
  iCaller.Comment.Shape.Width = 64
  If fA Then
    iCaller.FormulaArray = sF
  Else
    iCaller.Formula = sF
  End If
End Sub

Gõ công thức =UDF_ARRAYFORMULA({1,2,3;4,5,6;7,8,9}) trên trang tính và xem kết quả.
Cập nhật: Thử xóa ô chứa công thức và xem kết quả.