Cách viết Function (UDF) chạy như Sub

[Ngô Hải Đăng]

Mình ví dụ tạo Hàm Tô Màu, truyền vô 2 tham số dòng và cột. Nếu viết như vậy thì Excel sẽ báo lỗi

Function ToMauBinhThuong(ThamSo1 As Long, ThamSo2 As Long)
  Cells(ThamSo1, ThamSo2).Interior.Color = &HFF
End Function

Nhưng nếu mình viết như vậy thì Excel sẽ không báo lỗi nữa

Public ThamSo As Collection

Function ToMauBatThuong(ThamSo1 As Long, ThamSo2 As Long)
  Set ThamSo = New Collection
  ThamSo.Add ThamSo1
  ThamSo.Add ThamSo2
  Application.Caller.Parent.[0+ChaySub("S_ToMauBatThuong")]
End Function

Private Function ChaySub(TenSub As String)
  Application.Run TenSub
  Set ThamSo = Nothing
End Function

Private Sub S_ToMauBatThuong()
  Cells(ThamSo(1), ThamSo(2)).Interior.Color = &HFF
End Sub

Tại ô bất kỳ gõ công thức =ToMauBatThuong(Dòng số, Cột số)
Cách viết kiểu này thì vẫn còn 1 số hạn chế như: không thể dùng lệnh Clear, Delete,...Tuy nhiên nếu biết cách vận dụng thì sẽ tạo ra được 1 số hàm hữu ích cho mình.

Update code https://www.giaiphapexcel.com/diend...function-udf-chạy-như-sub.153245/post-1005047

 

[Ngô Hải Đăng]

Chỉnh Sub lại như vậy

Private Sub S_ToMauBatThuong()
  Cells.Interior.ColorIndex = 0
  Cells(ThamSo(1), ThamSo(2)).Interior.Color = &HFF
End Sub

Tại A1 gõ công thức =ToMauBatThuong(B1,C1)
Tại B1,C1 gõ 2 số bất kỳ rồi thử thay đổi để xem kết quả.

 

[ongke0711]

Nhưng nếu mình viết như vậy thì Excel sẽ không báo lỗi nữa

Public ThamSo As Collection

Function ToMauBatThuong(ThamSo1 As Long, ThamSo2 As Long)
  Set ThamSo = New Collection
  ThamSo.Add ThamSo1
  ...

Tôi thấy người ta hay dùng hàm EVALUATE trong mấy hàm này.

Option Explicit

Sub SetColor(rng As Range, colorVal As Long)
    rng.Interior.ColorIndex = colorVal
End Sub

Function DoiMauNen(DesRng, colorIdx)
    DesRng.Parent.Evaluate "SetColor(" & DesRng.Address(False, False) & "," & colorIdx & ")"
    DoiMauNen = "True"
End Function

Ví dụ: A1 = DoiMauNen (B1:F1,15)

 

[Ngô Hải Đăng]

Tôi thấy người ta hay dùng hàm EVALUATE trong mấy hàm này.

EVALUATE dạng viết tắt của nó là đặt công thức trong cặp ngoặc vuông [ ]. Như mình vẫn hay sài [A1], nếu viết đầy đủ ra là Evaluate("A1"). Trong code mình viết cũng có sài EVALUATE.

 

[Ngô Hải Đăng]

Mình Update code của bài #1. Viết như vậy cho tổng quát hơn

Public ThamSo As Collection

'1. Function chinh
Function ToMauBatThuong(ThamSo1 As Long, ThamSo2 As Long, Optional ThamSo3 As Long = 255)
  TruyenThamSo ThamSo1, ThamSo2, ThamSo3
  Application.Caller.Parent.[0+ChaySub("S_ToMauBatThuong")] '<--Thay ten Sub o day
End Function

'2. Sub chinh
Private Sub S_ToMauBatThuong()
  On Error GoTo KetThuc
  'Viet code o day
  Cells.Interior.ColorIndex = 0
  Cells(ThamSo(1), ThamSo(2)).Interior.Color = ThamSo(3)
  'Ket thuc code
  Exit Sub
KetThuc:
End Sub


'3. Sub, Function su dung trong Function chinh
Private Sub TruyenThamSo(ParamArray DayThamSo())
  Set ThamSo = New Collection
  Dim x As Byte
  For x = LBound(DayThamSo) To UBound(DayThamSo)
    ThamSo.Add DayThamSo(x)
  Next x
End Sub

Private Function ChaySub(TenSub As String)
  Application.Run TenSub
  Set ThamSo = Nothing
End Function

 

[Ngô Hải Đăng]

Mình đã tìm ra cách kết nối UFD với Sub thông qua Class Module mà không cần sài EVALUTE hoặc API. UDF chạy xong mới gọi Sub nên sẽ thao tác được mọi thứ trên sheet. Úp video demo trước rồi đi ngủ.

 

[tigertiger]

Mình đã tìm ra cách kết nối UFD với Sub thông qua Class Module mà không cần sài EVALUTE hoặc API. UDF chạy xong mới gọi Sub nên sẽ thao tác được mọi thứ trên sheet. Úp video demo trước rồi đi ngủ.

Rất hay,
Nên thử thu nhỏ phần kẻ khung lại xem thế nào? Có đáp ứng các nhu cầu của hàm động theo tham số không

 

[Ngô Hải Đăng]

Rất hay,
Nên thử thu nhỏ phần kẻ khung lại xem thế nào? Có đáp ứng các nhu cầu của hàm động theo tham số không

Vì thực chất của nó là chạy Sub nên động hay không còn tùy thuộc vào code tính toán bên trong Sub. UDF chỉ có vai trò truyền tham số (nếu có) và thực thi Sub.

 

[Hau151978]

Trước đây mình cũng có viết bài về hàm này, sử dụng evaluate hoặc worksheet_calculate, nếu sử dụng class thì có thể sửa đổi sự kiện này.

 

[huuthang_bd]

Phải giống cái này không?

 

[Ngô Hải Đăng]

Phải giống cái này không?

Nó đó anh, em có xem qua code bài này mà không có hiểu hết. Nhưng cũng biết thêm được cách bẫy Events trong class rồi ứng dụng vô code của em.

 

[Ngô Hải Đăng]

Trước đây mình cũng có viết bài về hàm này, sử dụng evaluate hoặc worksheet_calculate, nếu sử dụng class thì có thể sửa đổi sự kiện này.

Bạn thử tìm hiểu về khai báo WithEvents trong class module đi.

 

[Hau151978]

Bạn thử tìm hiểu về khai báo WithEvents trong class module đi.

Cái này mình làm lâu rồi nhưng không thấy hứng thú lắm. Mình dùng Excel 365 hỗ trợ công thức trả về mảng luôn rồi.

 

[Ngô Hải Đăng]

Cái này mình làm lâu rồi nhưng không thấy hứng thú lắm. Mình dùng Excel 365 hỗ trợ công thức trả về mảng luôn rồi.

Hiển thị công thức mảng chỉ là một ứng dụng của cách viết này thôi. Bạn nghĩ sao khi ta có thể giao tiếp với excel thông qua những câu lệnh. Ví dụ gõ =NewSheet thì nó sẽ tạo sheet mới, gõ =Music thì nó sẽ mở 1 bản nhạc nào đó...

 

[Hau151978]

Mình không nói về class vì đây là chủ đề rộng, mình chỉ đang nói về hàm trả về mảng thôi.

 

[Ngô Hải Đăng]

Mình up code để mọi người nghiên cứu nhé.
Đầu tiên là tạo Class Modules tên WSEvents để bắt sự kiên Worksheet_Calculate

Option Explicit

Public WithEvents Worksheet As Excel.Worksheet

Private Sub Worksheet_Calculate()
  RunSub True
End Sub

Sau đó là tạo 1 Modules để kết nối, mình đặt tên là SubConnection, các bạn muốn đặt tên gì cũng được

Option Explicit

Private oWSCalc As WSEvents
Private cSubList As Collection

Sub RunSub(IsRun As Boolean)
  If Not IsRun Then Exit Sub
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  On Error GoTo ResetCalculateMode
 
  Dim x&
  For x = 1 To cSubList.Count
    Application.Run cSubList(1)(2), cSubList(1)(1), cSubList(1)(3)
    cSubList.Remove 1
  Next x
 
ResetCalculateMode:
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  Set cSubList = Nothing
  Set oWSCalc = Nothing
End Sub

Function GetParameters(ParamArray iParamArray()) As Collection
  Set GetParameters = New Collection
  Dim x As Byte
  For x = LBound(iParamArray) To UBound(iParamArray)
    GetParameters.Add iParamArray(x)
  Next x
End Function

Sub ConnectSub(iCaller, iSubName As String, Optional iParameters)
  Set oWSCalc = New WSEvents
  Set oWSCalc.Worksheet = iCaller.Parent
  AddSub cSubList, iCaller, iSubName, iParameters
End Sub

Private Sub AddSub(iSubList As Collection, iCaller, iSubName As String, Optional iParameters)
  If iSubList Is Nothing Then Set iSubList = New Collection
  Dim aSubInfo(1 To 3)
  aSubInfo(1) = RangeName(iCaller)
  aSubInfo(2) = iSubName
  If Not IsMissing(iParameters) Then Set aSubInfo(3) = iParameters
  iSubList.Add aSubInfo
End Sub

Private Function RangeName(iRange) As String
  RangeName = "'['@WB_NAME']'@WS_NAME''!'@RNG_ADR'"
  RangeName = Replace(RangeName, "'@WB_NAME'", iRange.Parent.Parent.Name)
  RangeName = Replace(RangeName, "'@WS_NAME'", iRange.Parent.Name)
  RangeName = Replace(RangeName, "'@RNG_ADR'", iRange.Address)
End Function

Cuối cùng là tạo một Modules để viết UDF và Sub, mình viết mẫu 1 cái nhé

Function JumpSheet(iIndex)
  ConnectSub Application.Caller, "S_JumpSheet", GetParameters(iIndex)
End Function

Private Sub S_JumpSheet(iCaller As String, iParams As Collection)
  Range(iCaller).ClearContents 'Tùy UDF mà có hoặc không có dòng này
  On Error GoTo Finish
    Sheets(iParams(1)).Select
  Exit Sub
Finish:
  MsgBox "Khong co Sheet nay"
End Sub

UDF này sẽ di chuyển đến Sheet bạn muốn, Index có thể là Tên Sheet hoặc số thứ tự của Sheet, sau khi gõ xong thì cái UDF cũng tự mất luôn.
Hi vọng là mọi người sẽ tự tạo được nhiều UDF hữu ích cho mình.

 

[Ngô Hải Đăng]

Update code: Chỉ sử dụng 1 Class Module

1. 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

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
End Sub

Private Sub Worksheet_Calculate()
  Set Worksheet = 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 cParam = Nothing
  Set cCaller = Nothing
  fCalc = False
End Sub

2. Sử dụng Class trên Module

Option Explicit

Private oUDSF As New UDSF
    
Function UDF_ZOOM(iNum)
  UDF_ZOOM = "ZOOM"
  oUDSF.Link "UDS_ZOOM", iNum
End Function

Private Sub UDS_ZOOM(iParam, iCaller As Range)
  On Error GoTo MsgErr
  Excel.ActiveWindow.Zoom = iParam(1)
  Exit Sub
MsgErr:
  MsgBox Err.Description
End Sub

 

[Mr.hieudoanxd]

Tôi thấy người ta hay dùng hàm EVALUATE trong mấy hàm này.

Option Explicit

Sub SetColor(rng As Range, colorVal As Long)
    rng.Interior.ColorIndex = colorVal
End Sub

Function DoiMauNen(DesRng, colorIdx)
    DesRng.Parent.Evaluate "SetColor(" & DesRng.Address(False, False) & "," & colorIdx & ")"
    DoiMauNen = "True"
End Function

Ví dụ: A1 = DoiMauNen (B1:F1,15)

Em hỏi anh 1 chút, em có thử áp dụng hàm của anh để thay đổi chiều cao dòng bằng hàm UDF

Option Explicit

Sub RHV(rng As Range, value As Double)
    rng.Rowheight = value
End Sub

Function RowHeightValue(Des_Rng, Des_value)
    Des_Rng.Parent.Evaluate "RHV(" & Des_Rng.Address(False, False) & "," & Des_value & ")"
    RowHeightValue = "True"
End Function

nhưng không thấy được kết quả. A có thể chỉ giúp em lỗi được không ạ?

 

[Hoàng Trọng Nghĩa]

Em hỏi anh 1 chút, em có thử áp dụng hàm của anh để thay đổi chiều cao dòng bằng hàm UDF

Option Explicit
Function RowHeightValue(Des_Rng, Des_value)
    Des_Rng.Parent.Evaluate "RHV(" & Des_Rng.Address(False, False) & "," & Des_value & ")"
    RowHeightValue = "True"
End Function

Mình chưa hiểu cái chỗ sao True mà để trong ngoặc kép nhỉ?
RowHeightValue = "True"

 

[Mr.hieudoanxd]

Mình chưa hiểu cái chỗ sao True mà để trong ngoặc kép nhỉ?
RowHeightValue = "True"

Theo em nghĩ nó là giá trị trả về dạng stringthôi ạ, nếu bỏ đi thì giá trị trả về mặc định bằng 0