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

Liên hệ QC MyVTV Add-ins

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam

Ứ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.
PHP:
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.
PHP:
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ả.
 
Chỉnh sửa lần cuối bởi điều hành viên:

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
Mình cập nhật lại code ClassModule và code Hàm UDF_ARRAYFORMULA, code cũ khi chạy nhiều hàm UDF_ARRAYFORMULA cùng lúc thì không chính xác.

ClassModule
PHP:
Option Explicit

Const DEFAULTCALLBACK           As String = "Calculating..."
Private mParam                  As New Collection
Private mCaller                 As New Collection
Private mParamCB                As New Collection
Private mCallerCB               As New Collection
Private mCalc                   As Boolean
Private mCallBack               As Variant
Private mCurrentCaller          As Range
Private sCurrentFormula         As String
Private mArray                  As Boolean

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

Sub Link(ParamArray iSubParam())
  If TypeName(Application.Caller) <> "Range" Then Exit Sub
  If mCalc Then
    mCallerCB.Add Application.Caller
    mParamCB.Add iSubParam
  Else
    mCaller.Add Application.Caller
    mParam.Add iSubParam
    Set Worksheet = Application.Caller.Worksheet
  End If
End Sub

Sub AddComment(iHight, iWidth, Optional iClearFormat&)
  If Not mCurrentCaller.Comment Is Nothing Then mCurrentCaller.Comment.Delete
  mCurrentCaller.AddComment "$" & iHight & "$" & iWidth & "$" & iClearFormat
  mCurrentCaller.Comment.Shape.Height = 16
  mCurrentCaller.Comment.Shape.Width = 64
End Sub

Sub RemoveComment()
  DeleteComment mCurrentCaller
End Sub

Private Sub DeleteComment(iRange As Range)
  Dim aX
  If iRange.Comment Is Nothing Then Exit Sub
  aX = Split(iRange.Comment.Text, "$")
  On Error GoTo FN_
  iRange.Resize(aX(1), aX(2)) = Empty
  If aX(3) Then iRange.Resize(aX(1), aX(2)).ClearFormats
  iRange.Comment.Delete
FN_:
End Sub

Sub CallBack(iValue, Optional iCaller As Range)
  If Not mCalc Then iValue = DEFAULTCALLBACK: Exit Sub
  If iCaller Is Nothing Then
    If IsEmpty(mCallBack) Then
      iValue = DEFAULTCALLBACK
    Else
      iValue = mCallBack
      If IsArray(mCallBack) Then Erase mCallBack
      mCallBack = Empty
    End If
  Else
    mCallBack = iValue
    If IsEmpty(mCallBack) Then mCallBack = vbNullString
    If mArray Then
      iCaller.FormulaArray = sCurrentFormula
    Else
      iCaller.Formula = sCurrentFormula
    End If
  End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Application.CountA(Target) = 0 Then
    Dim rX As Range, aX, xAppCalc&
    xAppCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set Workbook = Nothing
    On Error GoTo Reset_
    Set rX = Target.Find("*", , xlComments)
    Debug.Print rX.Address
    While ((Not rX Is Nothing) And IsEmpty(rX.Value))
      DeleteComment rX
      If Not rX.Comment Is Nothing Then rX.Value = " "
      Set rX = Target.FindNext(rX)
    Wend
Reset_:
    Target = Empty
    Set Workbook = Application.ThisWorkbook
    Application.Calculation = xAppCalc
  End If
End Sub

Private Sub Worksheet_Calculate()
  Application.ScreenUpdating = False
  Set Worksheet = Nothing
  Set Workbook = Nothing
  mCalc = True
  On Error GoTo Reset_
  While mParam.Count > 0
    Set mCurrentCaller = mCaller(1)
    sCurrentFormula = mCaller(1).Formula
    mArray = mCaller(1).HasArray
    Application.Run mParam(1)(0), mParam(1), mCaller(1)
    mCaller.Remove 1
    mParam.Remove 1
  Wend
  Call CalculateCallBack
Reset_:
  Set mParam = Nothing
  Set mCaller = Nothing
  Set mParamCB = Nothing
  Set mCallerCB = Nothing
  Set mCurrentCaller = Nothing
  Set Workbook = Application.ThisWorkbook
  mCalc = False
  sCurrentFormula = Empty
  mArray = Empty
  Application.ScreenUpdating = True
End Sub

Private Sub CalculateCallBack()
  Dim fStop As Boolean, x&, y&
  y = 1
  Do
    fStop = True
    For x = mCallerCB.Count To y Step -1
      If mCallerCB(x).Value = DEFAULTCALLBACK Then
        fStop = False
        Set mCurrentCaller = mCallerCB(x)
        sCurrentFormula = mCallerCB(x).Formula
        mArray = mCallerCB(x).HasArray
        Application.Run mParamCB(x)(0), mParamCB(x), mCallerCB(x)
        y = x
      End If
    Next x
  Loop Until fStop
End Sub

Hàm UDF_ARRAYFORMULA
PHP:
Option Explicit

Public mUDSF As New UDSF
  
Function UDF_ARRAYFORMULA(iArray)
  mUDSF.Link "UDS_ARRAYFORMULA", iArray
  mUDSF.CallBack UDF_ARRAYFORMULA
End Function

Private Sub UDS_ARRAYFORMULA(iParam, iCaller As Range)
  If TypeName(iParam(1)) = "Range" Then iParam(1) = iParam(1)
  Dim x&, y&: 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
  mUDSF.RemoveComment
  iCaller.Resize(x, y) = iParam(1)
  mUDSF.AddComment x, y
  mUDSF.CallBack iCaller.Value, iCaller
End Sub
 
Lần chỉnh sửa cuối:

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Cho tôi hỏi: Chạy công thức =UDF_ARRAYFORMULA({1,2,3;4,5,6;7,8,9}) trên trang tính thì lỗi chỗ này là sao bạn?
(Đã bật Microsoft Scripting Runtime)

Cập nhật: Tôi biết rồi. Đặt tên cho ClassModule là UDSF
1621988212604.png1621988362554.png
 
Lần chỉnh sửa cuối:

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Nhưng sao vẫn còn comment ở ô chứa công thức vậy bạn ơi? Trong giải thuật buộc phải vậy hay bị sót?
 

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
À, hay thật! Nếu không thì biết đường nào mà xoá dữ liệu.

Nhưng phải có cách nào khác chứ nhỉ? Như ghi vào registry chẳng hạn.
Khó nhất ở chỗ khi thêm dòng hay cột thì phải cập nhật lại vị trí ô có công thức. Ghi vô comment thì đỡ phải suy nghĩ.
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Khó nhất ở chỗ khi thêm dòng hay cột thì phải cập nhật lại vị trí ô có công thức. Ghi vô comment thì đỡ phải suy nghĩ.
Tôi sửa code để ghi vào registry, gồm mấy thủ tục sau trong Class Module. Bạn xem thử có gì thừa không chứ tôi thử thì công thức hoạt động ổn.
(Trước đó tôi đã tạo cái Key TXXT tại đường dẫn HKEY_CURRENT_USER\SOFTWARE\)

Rich (BB code):
Sub AddComment(iHight, iWidth, Optional iClearFormat&)
Dim i_RegKey As String, i_Value As String, i_Type As String
Dim myWS As Object
Set myWS = CreateObject("WScript.Shell")
i_RegKey = "HKEY_CURRENT_USER\SOFTWARE\TXXT\TXT"
i_Value = "$" & iHight & "$" & iWidth & "$" & iClearFormat
i_Type = "REG_SZ"
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End Sub

Private Sub DeleteComment(iRange As Range)
  Dim aX, str As String
  Dim myWS As Object
 
  Set myWS = CreateObject("WScript.Shell")
  str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\TXXT\TXT")
  aX = Split(str, "$")
  On Error GoTo FN_
  iRange.Resize(aX(1), aX(2)) = Empty
  If aX(3) Then iRange.Resize(aX(1), aX(2)).ClearFormats
FN_:
Set myWS = Nothing
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Application.CountA(Target) = 0 Then
    Dim rX As Range, aX, xAppCalc&
    xAppCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set Workbook = Nothing
    On Error GoTo Reset_
 
  Dim str As String
  Dim myWS As Object
 
  On Error GoTo Reset_
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\TXXT\TXT")
  aX = Split(str, "$")
  Set rX = Range(Cells(Target.Row, Target.Column), Cells(Target.Row + aX(1) - 1, Target.Column + aX(2) - 1))
  DeleteComment rX
Reset_:
    Set myWS = Nothing
    Target = Empty
    Set Workbook = Application.ThisWorkbook
    Application.Calculation = xAppCalc
  End If
End Sub
 

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
Tôi sửa code để ghi vào registry, gồm mấy thủ tục sau trong Class Module. Bạn xem thử có gì thừa không chứ tôi thử thì công thức hoạt động ổn.
(Trước đó tôi đã tạo cái Key TXXT tại đường dẫn HKEY_CURRENT_USER\SOFTWARE\)

Rich (BB code):
Sub AddComment(iHight, iWidth, Optional iClearFormat&)
Dim i_RegKey As String, i_Value As String, i_Type As String
Dim myWS As Object
Set myWS = CreateObject("WScript.Shell")
i_RegKey = "HKEY_CURRENT_USER\SOFTWARE\TXXT\TXT"
i_Value = "$" & iHight & "$" & iWidth & "$" & iClearFormat
i_Type = "REG_SZ"
myWS.RegWrite i_RegKey, i_Value, i_Type
Set myWS = Nothing
End Sub

Private Sub DeleteComment(iRange As Range)
  Dim aX, str As String
  Dim myWS As Object
 
  Set myWS = CreateObject("WScript.Shell")
  str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\TXXT\TXT")
  aX = Split(str, "$")
  On Error GoTo FN_
  iRange.Resize(aX(1), aX(2)) = Empty
  If aX(3) Then iRange.Resize(aX(1), aX(2)).ClearFormats
FN_:
Set myWS = Nothing
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Application.CountA(Target) = 0 Then
    Dim rX As Range, aX, xAppCalc&
    xAppCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set Workbook = Nothing
    On Error GoTo Reset_
 
  Dim str As String
  Dim myWS As Object
 
  On Error GoTo Reset_
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\TXXT\TXT")
  aX = Split(str, "$")
  Set rX = Range(Cells(Target.Row, Target.Column), Cells(Target.Row + aX(1) - 1, Target.Column + aX(2) - 1))
  DeleteComment rX
Reset_:
    Set myWS = Nothing
    Target = Empty
    Set Workbook = Application.ThisWorkbook
    Application.Calculation = xAppCalc
  End If
End Sub
Cách này chưa ổn lắm vì mỗi lần sử dụng ở máy khác lại phải tạo Key. Và Code cũng mới hoạt động cho 1 hàm UDF_ARRAYFORMULA, nếu có hàm thứ 2 hoặc nhiều hơn thì chưa đúng. Theo mình nghĩ thì nên lưu luôn trên file Excel thì có gửi file qua máy khác vẫn sử dụng được. Cách này còn 1 điểm chưa ổn nữa là nếu công thức ở ô C3 mà vùng mình xóa từ A1:C3 thì hoạt động cũng chưa chính xác.
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Cách này chưa ổn lắm vì mỗi lần sử dụng ở máy khác lại phải tạo Key. Và Code cũng mới hoạt động cho 1 hàm UDF_ARRAYFORMULA, nếu có hàm thứ 2 hoặc nhiều hơn thì chưa đúng. Theo mình nghĩ thì nên lưu luôn trên file Excel thì có gửi file qua máy khác vẫn sử dụng được. Cách này còn 1 điểm chưa ổn nữa là nếu công thức ở ô C3 mà vùng mình xóa từ A1:C3 thì hoạt động cũng chưa chính xác.
Riêng Key thì không cần tạo, mình dùng ngay key SOFTWARE cũng được. Còn những thứ khác bạn xem lại thử thế nào, có cách viết khác không. Tôi mù tịt về Class Module
 
Lần chỉnh sửa cuối:

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
Tạm thời thì mình chưa nghĩ ra cách nào hay hơn là ghi vào comment. Có thể ghi thêm thông tin Địa chỉ của ô chứa công thức vào Registry để khi xóa thì nó sẽ kiểm tra xem vùng xóa có bao gồm địa chỉ ô công thức không, nếu có thì mới thực hiện lênh xóa, đồng thời xóa luôn thông tin Registry đó luôn, khi chạy hàm thì sẽ tạo lại Registry mới. Class Module giống như là mình tự tạo ra cái Object riêng của mình.
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Tạm thời thì mình chưa nghĩ ra cách nào hay hơn là ghi vào comment. Có thể ghi thêm thông tin Địa chỉ của ô chứa công thức vào Registry để khi xóa thì nó sẽ kiểm tra xem vùng xóa có bao gồm địa chỉ ô công thức không, nếu có thì mới thực hiện lênh xóa, đồng thời xóa luôn thông tin Registry đó luôn, khi chạy hàm thì sẽ tạo lại Registry mới. Class Module giống như là mình tự tạo ra cái Object riêng của mình.
Mãi rồi cũng tạm được. Tạo một string có dạng [Tênfile]TênSheet!ĐịaChỉÔ và ghi vào đó chuỗi như trong comment trước đây. Khi xóa thì như gợi ý của bạn: kiểm tra xem vùng xóa có bao gồm địa chỉ ô công thức không, nếu có thì thực hiện lênh xóa. Tôi chỉ lấn cấn tí chỗ này: hiện tôi đặt điều kiện nếu số ô của vùng xóa > 50 thì làm lơ đi, nghĩa là người dùng đã chủ động xóa hoặc có code khác xóa vùng, không biết có ổn không?

Code của hàm:
Rich (BB code):
Option Explicit

Public mUDSF As New UDSF
 
Function UDF_ARRAYFORMULA(iArray)
  mUDSF.Link "UDS_ARRAYFORMULA", iArray
  mUDSF.CallBack UDF_ARRAYFORMULA
End Function

Private Sub UDS_ARRAYFORMULA(iParam, iCaller As Range)
  If TypeName(iParam(1)) = "Range" Then iParam(1) = iParam(1)
  Dim x&, y&: 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
  Dim sAdrs As String, Sh As String, sFile As String
  sAdrs = iCaller.Address(0, 0)
  Sh = iCaller.Parent.Name
  sFile = "[" & iCaller.Parent.Parent.Name & "]"
  mUDSF.RemoveComment sFile & Sh & "!" & sAdrs
  iCaller.Resize(x, y) = iParam(1)
  mUDSF.AddComment x, y, sAdrs, sFile & Sh
  mUDSF.CallBack iCaller.Value, iCaller
End Sub

Code ClassModule
Rich (BB code):
Option Explicit

Const DEFAULTCALLBACK           As String = "Calculating..."
Private mParam                  As New Collection
Private mCaller                 As New Collection
Private mParamCB                As New Collection
Private mCallerCB               As New Collection
Private mCalc                   As Boolean
Private mCallBack               As Variant
Private mCurrentCaller          As Range
Private sCurrentFormula         As String
Private mArray                  As Boolean

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

Sub Link(ParamArray iSubParam())
    If TypeName(Application.Caller) <> "Range" Then Exit Sub
    If mCalc Then
        mCallerCB.Add Application.Caller
        mParamCB.Add iSubParam
    Else
        mCaller.Add Application.Caller
        mParam.Add iSubParam
        Set Worksheet = Application.Caller.Worksheet
    End If
End Sub

Sub AddComment(iHight, iWidth, strAdrs, sPath, Optional iClearFormat&)
Dim i_RegKey$, i_Value$, i_Type$
Dim myWS As Object
    'access Windows scripting
    Set myWS = CreateObject("WScript.Shell")
    'write registry key
    i_RegKey = "HKEY_CURRENT_USER\SOFTWARE\" & sPath & "!" & strAdrs
    i_Value = "$" & iHight & "$" & iWidth & "$" & iClearFormat
    i_Type = "REG_SZ"
    myWS.RegWrite i_RegKey, i_Value, i_Type
    Set myWS = Nothing
End Sub

Sub RemoveComment(strAdrs)
  DeleteComment mCurrentCaller, strAdrs
End Sub

Private Sub DeleteComment(iRange As Range, strAdrs)
  Dim aX, str As String, Cll As String
  Dim myWS As Object
 
    Cll = Right(strAdrs, Len(strAdrs) - InStr(1, strAdrs, "!"))
    'access Windows scripting
    Set myWS = CreateObject("WScript.Shell")
    'read key from registry
    On Error GoTo FN_
    str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\" & strAdrs)
    aX = Split(str, "$")
    Range(Cll).Resize(aX(1), aX(2)) = Empty
    If aX(3) Then Range(Cll).Resize(aX(1), aX(2)).ClearFormats
FN_:
    Set myWS = Nothing
End Sub

Sub CallBack(iValue, Optional iCaller As Range)
    If Not mCalc Then iValue = DEFAULTCALLBACK: Exit Sub
    If iCaller Is Nothing Then
        If IsEmpty(mCallBack) Then
          iValue = DEFAULTCALLBACK
        Else
          iValue = mCallBack
          If IsArray(mCallBack) Then Erase mCallBack
          mCallBack = Empty
        End If
    Else
        mCallBack = iValue
        If IsEmpty(mCallBack) Then mCallBack = vbNullString
        If mArray Then
          iCaller.FormulaArray = sCurrentFormula
        Else
          iCaller.Formula = sCurrentFormula
        End If
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Application.CountA(Target) = 0 Then
    Dim rX As Range, aX, xAppCalc&
    xAppCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set Workbook = Nothing
 
    Dim str$, sAdrs$, sPath$
    Dim myWS As Object
    Dim Cll As Range
 
    'access Windows scripting
    Set myWS = CreateObject("WScript.Shell")
    'read key from registry
    On Error Resume Next
    If Target.Count > 30 Then GoTo Reset_
    For Each Cll In Target
        sPath = "[" & Sh.Parent.Name & "]" & Sh.Name & "!" & Cll.Address(0, 0)
        str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\" & sPath)
        If str <> "" Then sAdrs = Cll.Address(0, 0): Exit For
    Next
    On Error GoTo 0
    On Error GoTo Reset_
    aX = Split(str, "$")
    Set rX = Range(Cells(Target.Row, Target.Column), Cells(Target.Row + aX(1) - 1, Target.Column + aX(2) - 1))
    DeleteComment rX, sPath
    myWS.RegDelete "HKEY_CURRENT_USER\SOFTWARE\" & sPath
Reset_:
    Set myWS = Nothing
    Target = Empty
    Set Workbook = Application.ThisWorkbook
    Application.Calculation = xAppCalc
  End If
End Sub

Private Sub Worksheet_Calculate()
    Application.ScreenUpdating = False
    Set Worksheet = Nothing
    Set Workbook = Nothing
    mCalc = True
    On Error GoTo Reset_
    While mParam.Count > 0
        Set mCurrentCaller = mCaller(1)
        sCurrentFormula = mCaller(1).Formula
        mArray = mCaller(1).HasArray
        Application.Run mParam(1)(0), mParam(1), mCaller(1)
        mCaller.Remove 1
        mParam.Remove 1
    Wend
    Call CalculateCallBack
Reset_:
  Set mParam = Nothing
  Set mCaller = Nothing
  Set mParamCB = Nothing
  Set mCallerCB = Nothing
  Set mCurrentCaller = Nothing
  Set Workbook = Application.ThisWorkbook
  mCalc = False
  sCurrentFormula = Empty
  mArray = Empty
  Application.ScreenUpdating = True
End Sub

Private Sub CalculateCallBack()
  Dim fStop As Boolean, x&, y&
  y = 1
  Do
    fStop = True
    For x = mCallerCB.Count To y Step -1
      If mCallerCB(x).Value = DEFAULTCALLBACK Then
        fStop = False
        Set mCurrentCaller = mCallerCB(x)
        sCurrentFormula = mCallerCB(x).Formula
        mArray = mCallerCB(x).HasArray
        Application.Run mParamCB(x)(0), mParamCB(x), mCallerCB(x)
        y = x
      End If
    Next x
  Loop Until fStop
End Sub
 

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
Mãi rồi cũng tạm được. Tạo một string có dạng [Tênfile]TênSheet!ĐịaChỉÔ và ghi vào đó chuỗi như trong comment trước đây. Khi xóa thì như gợi ý của bạn: kiểm tra xem vùng xóa có bao gồm địa chỉ ô công thức không, nếu có thì thực hiện lênh xóa. Tôi chỉ lấn cấn tí chỗ này: hiện tôi đặt điều kiện nếu số ô của vùng xóa > 50 thì làm lơ đi, nghĩa là người dùng đã chủ động xóa hoặc có code khác xóa vùng, không biết có ổn không?

Code của hàm:
Rich (BB code):
Option Explicit

Public mUDSF As New UDSF
 
Function UDF_ARRAYFORMULA(iArray)
  mUDSF.Link "UDS_ARRAYFORMULA", iArray
  mUDSF.CallBack UDF_ARRAYFORMULA
End Function

Private Sub UDS_ARRAYFORMULA(iParam, iCaller As Range)
  If TypeName(iParam(1)) = "Range" Then iParam(1) = iParam(1)
  Dim x&, y&: 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
  Dim sAdrs As String, Sh As String, sFile As String
  sAdrs = iCaller.Address(0, 0)
  Sh = iCaller.Parent.Name
  sFile = "[" & iCaller.Parent.Parent.Name & "]"
  mUDSF.RemoveComment sFile & Sh & "!" & sAdrs
  iCaller.Resize(x, y) = iParam(1)
  mUDSF.AddComment x, y, sAdrs, sFile & Sh
  mUDSF.CallBack iCaller.Value, iCaller
End Sub

Code ClassModule
Rich (BB code):
Option Explicit

Const DEFAULTCALLBACK           As String = "Calculating..."
Private mParam                  As New Collection
Private mCaller                 As New Collection
Private mParamCB                As New Collection
Private mCallerCB               As New Collection
Private mCalc                   As Boolean
Private mCallBack               As Variant
Private mCurrentCaller          As Range
Private sCurrentFormula         As String
Private mArray                  As Boolean

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

Sub Link(ParamArray iSubParam())
    If TypeName(Application.Caller) <> "Range" Then Exit Sub
    If mCalc Then
        mCallerCB.Add Application.Caller
        mParamCB.Add iSubParam
    Else
        mCaller.Add Application.Caller
        mParam.Add iSubParam
        Set Worksheet = Application.Caller.Worksheet
    End If
End Sub

Sub AddComment(iHight, iWidth, strAdrs, sPath, Optional iClearFormat&)
Dim i_RegKey$, i_Value$, i_Type$
Dim myWS As Object
    'access Windows scripting
    Set myWS = CreateObject("WScript.Shell")
    'write registry key
    i_RegKey = "HKEY_CURRENT_USER\SOFTWARE\" & sPath & "!" & strAdrs
    i_Value = "$" & iHight & "$" & iWidth & "$" & iClearFormat
    i_Type = "REG_SZ"
    myWS.RegWrite i_RegKey, i_Value, i_Type
    Set myWS = Nothing
End Sub

Sub RemoveComment(strAdrs)
  DeleteComment mCurrentCaller, strAdrs
End Sub

Private Sub DeleteComment(iRange As Range, strAdrs)
  Dim aX, str As String, Cll As String
  Dim myWS As Object
 
    Cll = Right(strAdrs, Len(strAdrs) - InStr(1, strAdrs, "!"))
    'access Windows scripting
    Set myWS = CreateObject("WScript.Shell")
    'read key from registry
    On Error GoTo FN_
    str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\" & strAdrs)
    aX = Split(str, "$")
    Range(Cll).Resize(aX(1), aX(2)) = Empty
    If aX(3) Then Range(Cll).Resize(aX(1), aX(2)).ClearFormats
FN_:
    Set myWS = Nothing
End Sub

Sub CallBack(iValue, Optional iCaller As Range)
    If Not mCalc Then iValue = DEFAULTCALLBACK: Exit Sub
    If iCaller Is Nothing Then
        If IsEmpty(mCallBack) Then
          iValue = DEFAULTCALLBACK
        Else
          iValue = mCallBack
          If IsArray(mCallBack) Then Erase mCallBack
          mCallBack = Empty
        End If
    Else
        mCallBack = iValue
        If IsEmpty(mCallBack) Then mCallBack = vbNullString
        If mArray Then
          iCaller.FormulaArray = sCurrentFormula
        Else
          iCaller.Formula = sCurrentFormula
        End If
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Application.CountA(Target) = 0 Then
    Dim rX As Range, aX, xAppCalc&
    xAppCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set Workbook = Nothing
 
    Dim str$, sAdrs$, sPath$
    Dim myWS As Object
    Dim Cll As Range
 
    'access Windows scripting
    Set myWS = CreateObject("WScript.Shell")
    'read key from registry
    On Error Resume Next
    If Target.Count > 30 Then GoTo Reset_
    For Each Cll In Target
        sPath = "[" & Sh.Parent.Name & "]" & Sh.Name & "!" & Cll.Address(0, 0)
        str = myWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\" & sPath)
        If str <> "" Then sAdrs = Cll.Address(0, 0): Exit For
    Next
    On Error GoTo 0
    On Error GoTo Reset_
    aX = Split(str, "$")
    Set rX = Range(Cells(Target.Row, Target.Column), Cells(Target.Row + aX(1) - 1, Target.Column + aX(2) - 1))
    DeleteComment rX, sPath
    myWS.RegDelete "HKEY_CURRENT_USER\SOFTWARE\" & sPath
Reset_:
    Set myWS = Nothing
    Target = Empty
    Set Workbook = Application.ThisWorkbook
    Application.Calculation = xAppCalc
  End If
End Sub

Private Sub Worksheet_Calculate()
    Application.ScreenUpdating = False
    Set Worksheet = Nothing
    Set Workbook = Nothing
    mCalc = True
    On Error GoTo Reset_
    While mParam.Count > 0
        Set mCurrentCaller = mCaller(1)
        sCurrentFormula = mCaller(1).Formula
        mArray = mCaller(1).HasArray
        Application.Run mParam(1)(0), mParam(1), mCaller(1)
        mCaller.Remove 1
        mParam.Remove 1
    Wend
    Call CalculateCallBack
Reset_:
  Set mParam = Nothing
  Set mCaller = Nothing
  Set mParamCB = Nothing
  Set mCallerCB = Nothing
  Set mCurrentCaller = Nothing
  Set Workbook = Application.ThisWorkbook
  mCalc = False
  sCurrentFormula = Empty
  mArray = Empty
  Application.ScreenUpdating = True
End Sub

Private Sub CalculateCallBack()
  Dim fStop As Boolean, x&, y&
  y = 1
  Do
    fStop = True
    For x = mCallerCB.Count To y Step -1
      If mCallerCB(x).Value = DEFAULTCALLBACK Then
        fStop = False
        Set mCurrentCaller = mCallerCB(x)
        sCurrentFormula = mCallerCB(x).Formula
        mArray = mCallerCB(x).HasArray
        Application.Run mParamCB(x)(0), mParamCB(x), mCallerCB(x)
        y = x
      End If
    Next x
  Loop Until fStop
End Sub
Nếu là mình thì sẽ làm như vậy:
- Khi chạy hàm, tạo 1 Registry có Value là [Workbook]Sheet!Address<$>Rows<$>Column (mình dùng <$> cho khỏi trùng với $ trong Address). Registry phải đặt trong vùng mình kiểm soát được.
-Khi xóa thì mình sẽ có thông tin vùng bị xóa (Target). Sau đó duyệt qua các Registry mà hàm đã tạo. Kiểm tra bằng cách Intersect(Target, range([Workbook]Sheet!Address)). Nếu khác Nothing thì range([Workbook]Sheet!Address).Resize(Rows,Column) = Empty

Thay vì ghi vào Registry bạn thử ghi vào Name của excel xem sao, cách làm tương tự
 

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
Cập nhật lại Class Module, trong file test có thêm 2 hàm Sort và Unique viết theo cách Sort và RemoveDupticate của excel.
PHP:
Option Explicit

Const DEFAULTCALLBACK           As String = "Calculating..."
Private mParam                  As New Collection
Private mCaller                 As New Collection
Private mCurrentCaller          As Range
Private sCurrentFormula         As String
Private mArray                  As Boolean
Private mCalc                   As Boolean
Private mCallBack               As Variant

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

Sub Link(ParamArray iSubParam())
  If TypeName(Application.Caller) <> "Range" Then Exit Sub
  If Exist(Application.Caller) Then Exit Sub
  mCaller.Add Application.Caller
  mParam.Add iSubParam
  If mCalc Then Exit Sub
  Set Worksheet = Application.Caller.Worksheet
End Sub

Sub AddComment(iHight, iWidth, Optional iClearFormat&)
  If Not mCurrentCaller.Comment Is Nothing Then mCurrentCaller.Comment.Delete
  mCurrentCaller.AddComment "$" & iHight & "$" & iWidth & "$" & iClearFormat
  mCurrentCaller.Comment.Shape.Height = 0
  mCurrentCaller.Comment.Shape.Width = 0
End Sub

Sub RemoveComment()
  DeleteComment mCurrentCaller
End Sub

Private Sub DeleteComment(iRange As Range)
  Dim aX
  If iRange.Comment Is Nothing Then Exit Sub
  aX = Split(iRange.Comment.Text, "$")
  On Error GoTo FN_
  iRange.Resize(aX(1), aX(2)) = Empty
  If aX(3) Then iRange.Resize(aX(1), aX(2)).ClearFormats
  iRange.Comment.Delete
FN_:
End Sub

Sub CallBack(iValue, Optional iCaller As Range)
  If Not mCalc Then iValue = DEFAULTCALLBACK: Exit Sub
  If iCaller Is Nothing Then
    If IsEmpty(mCallBack) Then
      iValue = DEFAULTCALLBACK
    Else
      iValue = mCallBack
      If IsArray(mCallBack) Then Erase mCallBack
      mCallBack = Empty
    End If
  Else
    mCallBack = iValue
    If IsEmpty(mCallBack) Then mCallBack = vbNullString
    If mArray Then
      iCaller.FormulaArray = sCurrentFormula
    Else
      iCaller.Formula = sCurrentFormula
    End If
  End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Application.CountA(Target) = 0 Then
    Dim rX As Range, aX, xAppCalc&
    xAppCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set Workbook = Nothing
    On Error GoTo Reset_
    Set rX = Target.Find("*", , xlComments)
    Debug.Print rX.Address
    While ((Not rX Is Nothing) And IsEmpty(rX.Value))
      DeleteComment rX
      If Not rX.Comment Is Nothing Then rX.Value = " "
      Set rX = Target.FindNext(rX): Debug.Print rX.Address
    Wend
Reset_:
    Target = Empty
    Set Workbook = Application.ThisWorkbook
    Application.Calculation = xAppCalc
  End If
End Sub

Private Sub Worksheet_Calculate()
  Dim x&
  Application.ScreenUpdating = False
  Set Worksheet = Nothing
  Set Workbook = Nothing
  mCalc = True
  On Error GoTo Reset_
  While x < mParam.Count
    x = x + 1
    Set mCurrentCaller = mCaller(x)
    sCurrentFormula = mCaller(x).Formula
    mArray = mCaller(x).HasArray
    Application.Run mParam(x)(0), mParam(x), mCaller(x)
  Wend
  Call CalculateCallBack
' Stop
Reset_:
  Set mParam = Nothing
  Set mCaller = Nothing
  Set mCurrentCaller = Nothing
  Set Workbook = Application.ThisWorkbook
  mCalc = False
  sCurrentFormula = Empty
  mArray = Empty
  Application.ScreenUpdating = True
End Sub

Private Sub CalculateCallBack()
  Dim fStop As Boolean, x&, y&
  y = mCaller.Count
  Do
    y = y - 1
    fStop = True
    If y >= 0 Then CheckError
    For x = mCaller.Count To 1 Step -1
      If mCaller(x).Text = DEFAULTCALLBACK Then
        fStop = False
        Set mCurrentCaller = mCaller(x)
        sCurrentFormula = mCaller(x).Formula
        mArray = mCaller(x).HasArray
        Application.Run mParam(x)(0), mParam(x), mCaller(x)
      End If
    Next x
  Loop Until fStop Or y < 0
End Sub

Private Sub CheckError()
  Dim x&
  For x = mCaller.Count To 1 Step -1
    If IsError(mCaller(x).Value) Then
      Set mCurrentCaller = mCaller(x)
      sCurrentFormula = mCaller(x).Formula
      mArray = mCaller(x).HasArray
      mCaller.Remove x
      mParam.Remove x
      If mArray Then
        mCurrentCaller.FormulaArray = sCurrentFormula
      Else
       mCurrentCaller.Formula = sCurrentFormula
      End If
    End If
  Next x
End Sub

Private Function Exist(iCaller As Range) As Boolean
  Dim x&
  For x = 1 To mCaller.Count
    If iCaller.Parent Is mCaller(x).Parent Then
      If Not Intersect(iCaller, mCaller(x)) Is Nothing Then Exist = True: Exit Function
    End If
  Next x
End Function
 

File đính kèm

  • TestClass.xlsb
    42.9 KB · Đọc: 8

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Cập nhật cho bài #12, cứ xóa đúng ô chứa công thức là xóa vùng dữ liệu bất kỳ xóa bằng cách gì.
 

File đính kèm

  • HamDictionary_R.xlsm
    207 KB · Đọc: 5

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Cập nhật cho bài #12, cứ xóa đúng ô chứa công thức là xóa vùng dữ liệu bất kỳ xóa bằng cách gì.
Cập nhật: Tạo registry string value ARR nếu chưa có:
Rich (BB code):
Private Sub DeleteComment(iRange As Range, strAdrs)
  Dim aX, str As String, Cll As String
  Dim MyWS As Object
 
    Cll = Right(strAdrs, Len(strAdrs) - InStr(1, strAdrs, "!"))
    'access Windows scripting
    Set MyWS = CreateObject("WScript.Shell")
    'read key from registry
    On Error Resume Next
    str = MyWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\ARR")
    If Err.Number <> 0 Then MyWS.RegWrite "HKEY_CURRENT_USER\SOFTWARE\ARR", str, "REG_SZ"
    On Error GoTo 0
    On Error GoTo FN_
    str = MyWS.RegRead("HKEY_CURRENT_USER\SOFTWARE\" & strAdrs)
    aX = Split(str, "$")
    Range(Cll).Resize(aX(1), aX(2)) = Empty
    If aX(3) Then Range(Cll).Resize(aX(1), aX(2)).ClearFormats
FN_:
    Set MyWS = Nothing
End Sub
 

File đính kèm

  • HamDictionary_R.xlsm
    207.3 KB · Đọc: 0
Lần chỉnh sửa cuối:

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Cập nhật: dùng Comment của Worksheet Name để ghi kích thước mảng
 

File đính kèm

  • HamDictionary_N.xlsm
    211.5 KB · Đọc: 5

Ngô Hải Đăng

Thành viên hoạt động
Tham gia ngày
31 Tháng tám 2017
Bài viết
145
Được thích
158
Giới tính
Nam
Cập nhật: dùng Comment của Worksheet Name để ghi kích thước mảng
PHP:
mUDSF.Link "UDS_ARRAYFORMULA", SumDicMM
mUDSF.CallBack SumDicMM
Thêm đoạn code này vào cuối hàm SumDicMM rồi trên sheet gõ = SumDicMM luôn, khỏi phải qua ArrayFormula.
 

Maika8008

Tích cực để lên đời
Tham gia ngày
12 Tháng sáu 2020
Bài viết
1,673
Được thích
1,764
Giới tính
Nam
Lỗi bài #17 - xóa nhiều công thức chỉ xóa được vùng dữ liệu đầu tiên => đã sửa.

(Đã áp dụng ổn cho công thức truy vấn SQL của tác giả)
 

File đính kèm

  • HamDictionary_N.xlsm
    210.6 KB · Đọc: 8
Top Bottom