Viết hàm tự tạo theo kiểu Excel 365

Ngô Hải Đăng · 23/10/20

Nghiên cứu trên diễn đàn thì phát hiện được cái Application.Caller và sau đây là ý tưởng của mình:
1. Code trên ThisWorkbook

Mã:

Option Explicit

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    If IsUDF Then
        SetResult
        rCaller.Formula = sFormula
    End If
End Sub

Private Sub SetResult()
    Dim r0&, c0&
    On Error Resume Next
    r0 = UBound(aResult, 1) - LBound(aResult, 1)
    c0 = UBound(aResult, 2) - LBound(aResult, 2)
    On Error GoTo 0
    If c0 = 0 Then
        rCaller.Resize(1, r0 + 1) = aResult
    Else
        rCaller.Resize(r0 + 1, c0 + 1) = aResult
    End If
End Sub

2. Code trên Module

Mã:

Option Explicit

Public IsUDF As Boolean
Public rCaller As Range
Public aResult As Variant
Public sFormula As String

Function MyUDF()
    If IsUDF Then
        MyUDF = aResult
        IsUDF = False
        Set rCaller = Nothing
        If IsArray(aResult) Then Erase aResult Else aResult = Empty
    Else
        IsUDF = True
        Set rCaller = Application.Caller
        sFormula = rCaller.Formula
        
        'Dim tmp As String: tmp = "1 GIA TRI"
        'Dim tmp: tmp = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
        Dim tmp(10, 15) As Long
        aResult = tmp
    End If
End Function

3. Gõ =MyUDF() trên Sheet để test.

Có thể thử với kết quả là 1 giá trị, mảng 1 chiều và mảng 2 chiều. Mong được học hỏi thêm kinh nghiệm từ mọi người.

Kiều Mạnh · 12/11/20

...........................

ptm0412 · 12/11/20

Kiều Mạnh đã viết:
Thông Tin các gói Office 365 chi tiết đấy

Gói miễn phí có phải chỉ dùng online (trên web) không @Kiều Mạnh?

Kiều Mạnh · 12/11/20

.....................

Kiều Mạnh · 12/11/20

........................

befaint · 12/11/20

Kiều Mạnh đã viết:
khi nào rảnh quậy 1 chút ... 1 năm sau rành món này lại rành luôn cả Google Sheet đây

Có cái mới lại bỏ cái cũ đi ... chơi hoài chán lắm

View attachment 249206

Cái Automate hịn đó anh.
Thêm cái Power Automate nữa thì mọi thứ hoạt động tự động trên cloud.

ptm0412 · 12/11/20

Kiều Mạnh đã viết:
Em mới thử rút cáp mạng ra thấy xài ok đó Anh
Có mạng thì Anh xài cả 2 như hình nè ...

Đang mở excel online rồi rút cáp, hay rút cáp trước khi mở Excel bằng web browser? Ngoài ra chạy offline nó cũng lưu vào thư mục one drive trên máy, sau đó khi online sẽ đồng bộ với cloud.

Kiều Mạnh đã viết:
Anh thấy giao diện đẹp lung linh chưa ????????????

Chẳng qua là khoe hàng chứ giao diện 365 theme black nó nung ninh như nhau, tuỳ gói sẽ có thêm tab này tab kia thôi.

Kiều Mạnh · 12/11/20

................

befaint · 13/11/20

ptm0412 đã viết:
mới gần đây xảy ra một vụ kiện cáo xoá bài

Thật đáng buồn!

Tới giờ này các anh vẫn chưa nhìn nhận ra vấn đề, hoặc theo một hướng nào đó…

Em khẳng định là không có vụ khiếu nại, tố cáo tội phạm, kiện cáo gì cả.

--- Giải thích ---

1/ Trang web giaiphapexcel.com thuộc sở hữu của anh Bình, thông tin chi tiết lấy từ trang https://who.is/ như hình dưới. Sau đây gọi là chủ quản diễn đàn.

2/ Chủ quản diễn đàn trao quyền cho các admin/ mod theo thỏa thuận (nào đó) thực hiện các công việc quản trị diễn đàn. Gọi là ban quản trị (BQT).

3/ Sự việc thành viên X xóa các bài viết của mình có tác động gì tới diễn đàn?

- Làm mất tài sản của diễn đàn;

- Tác động tới các thành viên đã giúp đỡ trong chủ đề đó, tới các thành viên khác khi đọc chủ đề đó. Tác động tiêu cực hay tốt đẹp như nào thì các thành viên tự đánh giá, nhưng chắc chắn là không tôn trọng những người đã giúp X.

- Tạo tiền đề (xấu, tốt) cho những sự việc tương tự, hay kéo theo sau này nếu BQT không có biện pháp xử lý/ ngăn chặn phù hợp và kịp thời.

4/ Thành viên Y “tố cáo, kiện cáo” thành viên X tới BQT được gì?

- Qua sự việc vừa rồi đã phát hiện và đúc rút được một số thứ.

Còn BQT tới giờ chưa nhìn nhận ra vấn đề, hoặc theo một hướng khác.

- Không có vụ tố cáo, kiện cáo gì ở đây cả. Bởi:

Nguyên cáo là ai? Nếu thua/ thắng kiện thì được gì?

Bị cáo là ai? Đã làm tổn hại gì tới nguyên cáo?

Tòa án ở đây là ai? Là BQT chăng? Các anh/ chị BQT đang thay mặt chủ quản diễn đàn quản lý cơ mà .

Thành viên X làm ảnh hưởng tới tài sản của các anh thì các anh tự xử đi chứ. Sao lại gọi là kiện cáo gì.

Còn thành viên Y kia rảnh quá la làng lên cho các anh biết có sự việc như vậy đấy (bởi X âm thầm làm, chưa có ai biết mà). Như kiểu có kẻ thải bẩn ra cổng, có ông hàng xóm đi qua nhìn thấy và la làng lên “Có kẻ làm bẩn ra cổng nhà anh/ chị này, anh/ chị ra mà dọn đi”.

Thành viên Y thông báo, cung cấp thông tin cho BQT, phản ánh một sự việc tới BQT, chứ không có vụ kiện cáo nào cả.

5/ (Nhân tiện cho các thành viên tham khảo)

Trường hợp nếu thành viên X làm tổn hại gì đó tới thành viên Y thì:

- Thành viên Y kiến nghị tới BQT xử lý;

- Nếu BQT xử lý không thỏa đáng, hoặc không, hoặc chưa kịp thời xử lý thì thành viên Y tố cáo/ đệ đơn kiện tới cơ quan có thẩm quyền can thiệp (Cơ quan Công an, Tòa án…) với nội dung: Thành viên X làm tổn hại xyz, BQT diễn đàn xử lý sự việc không thỏa đáng, hoặc không/ chưa xử lý. Bây giờ có Luật an ninh mạng rõ ràng rồi.

----
Mong là sẽ sớm có phương án xử lý hợp lý (Tương tự như cách ngăn chặn sự việc có chiều hướng không tốt có thể xảy ra).

SA_DQ · 14/11/20

Viết hàm SWITCH2003() để dùng cho Excel version thấp, như E2003

PHP:

 Option Explicit
Function SWITCH2003(Num As Double) As String
SWITCH2003 = Switch(Num <= 0, "A", Num <= 5, "B", Num <= 10, "C", Num <= 15, "D", Num > 15, "E")
End Function

Mã:

Function SWITCH2003(Num As Double) As Long
SWITCH2003 = Switch(Num <= 0, 0, Num <= 5, 5, Num <= 10, 10, Num <= 15, 15, Num > 15, 20)
End Function

PHP:

Function MINIF(CSDL As Range, Ma As String) As Double
 Dim WF As Object, J As Long
 
 Set WF = Application.WorksheetFunction
 MINIF = WF.Max(CSDL(2).Resize(CSDL.Rows.Count))
 For J = 1 To CSDL.Rows.Count
    If CSDL.Cells(J, "A").Value = Ma Then
        If CSDL.Cells(J, "B").Value < MINIF Then MINIF = CSDL.Cells(J, "B").Value
    End If
 Next J
End Function

Hai Lúa Miền Tây · 19/11/20

Hàm được chạy trên Office 365:

Hoàng Nhật Phương · 19/11/20

Hai Lúa Miền Tây đã viết:
Hàm được chạy trên Office 365:

Thích quá, thích quá, hồi hộp quá anh Hai Lúa ơi :throb:

Hai Lúa Miền Tây · 19/11/20

NHN_Phương đã viết:
Thích quá, thích quá, hồi hộp quá anh Hai Lúa ơi

Hồi hộp vụ gì em? Hàm trên nó chạy tốt cho Office 365, nhưng trên Office bình thường thì anh chỉ biết cho nó ra hàm mảng bình thường thôi.

Hoàng Nhật Phương · 19/11/20

Hai Lúa Miền Tây đã viết:
Hồi hộp vụ gì em? Hàm trên nó chạy tốt cho Office 365, nhưng trên Office bình thường thì anh chỉ biết cho nó ra hàm mảng bình thường thôi.

Dạ hồi hộp vì chờ đợi (hóng) các sản phẩm của anh Hai Lúa ạ.
Hàm nó ra mảng hay ra gì cũng được anh miễn là một công thức một câu lệnh mà nó đỏ xuống không cần phải co kéo thêm gì cả ấy anh à, cũng thấy hay hay anh ạ.
OT cũng thấy mỗi lần các chuyên gia trao đổi và bàn luận đến chủ đề kiểu này này là lại thấy có lửa bốc lên mà hãi quá. hihi

Ngô Hải Đăng · 19/11/20

Hai Lúa Miền Tây đã viết:
Hàm được chạy trên Office 365:

Office 365 đã hỗ trợ các hàm mảng rồi nên chỉ cần xây dựng hàm trả về mảng là excel nó sẽ tự làm hết. Bác thử trên các phiên bản khác thì nó sẽ không làm được như vậy.

Hai Lúa Miền Tây · 19/11/20

Ngô Hải Đăng đã viết:
Office 365 đã hỗ trợ các hàm mảng rồi nên chỉ cần xây dựng hàm trả về mảng là excel nó sẽ tự làm hết. Bác thử trên các phiên bản khác thì nó sẽ không làm được như vậy.

Đúng là thế, tuy nhiên đang tìm cách để cho nó giống giống với Office 365.

Ngô Hải Đăng · 19/11/20

Hai Lúa Miền Tây đã viết:
Đúng là thế, tuy nhiên đang tìm cách để cho nó giống giống với Office 365.

Bác thử code này xem, tuy nhiên chỉ mới là bước đầu thôi, fill được cái mảng lên sheet.

Mã:

Option Explicit

Public rCaller As Range
Public aResult
Public nCount As Byte

Function HDFillResult(iArray, Optional iDynamic As Boolean)
    On Error GoTo Reset
    Select Case nCount
        Case Is = 0:
            nCount = 1
            If iDynamic Then Application.Volatile
            If TypeName(iArray) = "Range" Then
                Set aResult = iArray
            Else
                If IsArray(aResult) Then
                  aResult = iArray
                Else
                  aResult = iArray
                End If
            End If
            Set rCaller = Application.Caller
            HDFillResult = Evaluate(rCaller.Formula)
        Case Is = 1:
            nCount = 2
            SetResult2 rCaller, aResult
            HDFillResult = aResult
        
        Case Else:
            HDFillResult = aResult
            GoTo Reset
    End Select
    Exit Function
Reset:
    HDResetAll
End Function

Function HDResetAll() As Boolean
    HDResetAll = rCaller Is Nothing
    Set rCaller = Nothing
    If TypeName(aResult) = "Range" Then
      Set aResult = Nothing
    Else
      If IsArray(aResult) Then Erase aResult Else aResult = Empty
    End If
    nCount = Empty
End Function

Private Sub SetResult2(iCell As Range, iArray)
    Dim r0&, c0&
    GetSizeArray iArray, r0, c0
    If r0 + c0 = 2 Then Exit Sub
    Application.ScreenUpdating = False
    On Error GoTo ResetScreenUpdate
    If TypeName(iArray) = "Range" Then
        If c0 > 1 Then iCell.Resize(1, c0 - 1).Offset(0, 1) = iArray.Resize(1, c0 - 1).Offset(0, 1).Value
        If r0 > 1 Then iCell.Resize(r0 - 1, c0).Offset(1, 0) = iArray.Resize(r0 - 1, c0).Offset(1, 0).Value
    Else
        If r0 = 1 Then
            If c0 > 2 Then
                iCell.Resize(1, c0 - 1).Offset(0, 1) = iArray
                iCell.Resize(1, c0 - 2).Offset(0, 1) = iCell.Resize(1, c0 - 2).Offset(0, 2).Value
            End If
            iCell.Offset(0, c0 - 1) = Application.Index(iArray, 1, c0)
        Else
            iCell.Resize(r0 - 1, c0).Offset(1, 0) = iArray
            If r0 > 2 Then iCell.Resize(r0 - 2, 1).Offset(1, 0) = iCell.Resize(r0 - 2, 1).Offset(2, 0).Value
            If c0 > 1 Then iCell.Resize(r0 - 1, c0 - 1).Offset(0, 1) = iCell.Resize(r0 - 1, c0 - 1).Offset(1, 1).Value
            iCell.Offset(r0 - 1, 0).Resize(1, c0) = Application.Index(iArray, r0, 0)
        End If
    End If
    Exit Sub
ResetScreenUpdate:
    Application.ScreenUpdating = True
End Sub

Private Sub GetSizeArray(iArray, iRows As Long, iColumns As Long)
    If TypeName(iArray) = "Range" Then
        iRows = iArray.Rows.Count
        iColumns = iArray.Columns.Count
    Else
        iColumns = -1
        On Error Resume Next
        iRows = UBound(iArray, 1) - LBound(iArray, 1)
        iColumns = UBound(iArray, 2) - LBound(iArray, 2)
        If iColumns = -1 Then iColumns = iRows: iRows = 0
        iRows = iRows + 1: iColumns = iColumns + 1
    End If
End Sub

Hoàng Nhật Phương · 19/11/20

Ngô Hải Đăng đã viết:

Bác thử code này xem, tuy nhiên chỉ mới là bước đầu thôi, fill được cái mảng lên sheet.

Mã:

Option Explicit

Public rCaller As Range
Public aResult
Public nCount As Byte

Function HDFillResult(iArray, Optional iDynamic As Boolean)
    On Error GoTo Reset
    Select Case nCount
        Case Is = 0:
            nCount = 1
            If iDynamic Then Application.Volatile
            If TypeName(iArray) = "Range" Then
                Set aResult = iArray
            Else
                If IsArray(aResult) Then
                  aResult = iArray
                Else
                  aResult = iArray
                End If
            End If
            Set rCaller = Application.Caller
            HDFillResult = Evaluate(rCaller.Formula)
        Case Is = 1:
            nCount = 2
            SetResult2 rCaller, aResult
            HDFillResult = aResult
       
        Case Else:
            HDFillResult = aResult
            GoTo Reset
    End Select
    Exit Function
Reset:
    HDResetAll
End Function

Function HDResetAll() As Boolean
    HDResetAll = rCaller Is Nothing
    Set rCaller = Nothing
    If TypeName(aResult) = "Range" Then
      Set aResult = Nothing
    Else
      If IsArray(aResult) Then Erase aResult Else aResult = Empty
    End If
    nCount = Empty
End Function

Private Sub SetResult2(iCell As Range, iArray)
    Dim r0&, c0&
    GetSizeArray iArray, r0, c0
    If r0 + c0 = 2 Then Exit Sub
    Application.ScreenUpdating = False
    On Error GoTo ResetScreenUpdate
    If TypeName(iArray) = "Range" Then
        If c0 > 1 Then iCell.Resize(1, c0 - 1).Offset(0, 1) = iArray.Resize(1, c0 - 1).Offset(0, 1).Value
        If r0 > 1 Then iCell.Resize(r0 - 1, c0).Offset(1, 0) = iArray.Resize(r0 - 1, c0).Offset(1, 0).Value
    Else
        If r0 = 1 Then
            If c0 > 2 Then
                iCell.Resize(1, c0 - 1).Offset(0, 1) = iArray
                iCell.Resize(1, c0 - 2).Offset(0, 1) = iCell.Resize(1, c0 - 2).Offset(0, 2).Value
            End If
            iCell.Offset(0, c0 - 1) = Application.Index(iArray, 1, c0)
        Else
            iCell.Resize(r0 - 1, c0).Offset(1, 0) = iArray
            If r0 > 2 Then iCell.Resize(r0 - 2, 1).Offset(1, 0) = iCell.Resize(r0 - 2, 1).Offset(2, 0).Value
            If c0 > 1 Then iCell.Resize(r0 - 1, c0 - 1).Offset(0, 1) = iCell.Resize(r0 - 1, c0 - 1).Offset(1, 1).Value
            iCell.Offset(r0 - 1, 0).Resize(1, c0) = Application.Index(iArray, r0, 0)
        End If
    End If
    Exit Sub
ResetScreenUpdate:
    Application.ScreenUpdating = True
End Sub

Private Sub GetSizeArray(iArray, iRows As Long, iColumns As Long)
    If TypeName(iArray) = "Range" Then
        iRows = iArray.Rows.Count
        iColumns = iArray.Columns.Count
    Else
        iColumns = -1
        On Error Resume Next
        iRows = UBound(iArray, 1) - LBound(iArray, 1)
        iColumns = UBound(iArray, 2) - LBound(iArray, 2)
        If iColumns = -1 Then iColumns = iRows: iRows = 0
        iRows = iRows + 1: iColumns = iColumns + 1
    End If
End Sub

Nhìn code mà thấy hãi quá,phiền bạn có thể đính kèm ví dụ để tôi tham khảo thêm với được không?

Ngô Hải Đăng · 19/11/20

NHN_Phương đã viết:
Nhìn code mà thấy hãi quá,phiền bạn có thể đính kèm ví dụ để tôi tham khảo thêm với được không?

Bạn xem file nhé.

Hoàng Nhật Phương · 19/11/20

Ngô Hải Đăng đã viết:
Bạn xem file nhé.

Cảm ơn bạn nhiều,ủa công thức vẫn phải bấm tổ hợp phím "ctrl shift enter" à bạn ? hihi :-=

Ngô Hải Đăng · 19/11/20

NHN_Phương đã viết:
Cảm ơn bạn nhiều,ủa công thức vẫn phải bấm tổ hợp phím "ctrl shift enter" à bạn ? hihi

Vì cái này là sẵn có của excel nên phải "Ctr Shift Enter" nó mới trả về mảng, còn nếu mình tự tạo hàm mảng riêng thì không cần.
Bạn thử gõ công thức này tại ô A20 xem

Mã:

=HDFillResult(A1:K11)

Sau đó thử với công thức =A1:K11 sẽ thấy sự khác biệt.

Viết hàm tự tạo theo kiểu Excel 365

Thành viên hoạt động

I don't program, I beat code into submission!!!

Bad Excel Member

I don't program, I beat code into submission!!!

I don't program, I beat code into submission!!!

|||||||||||||

Bad Excel Member

I don't program, I beat code into submission!!!

|||||||||||||

/(hông là gì!

❆❆❆❆❆❆❆❆

Thành viên gắn bó

❆❆❆❆❆❆❆❆

Thành viên gắn bó

Thành viên hoạt động

❆❆❆❆❆❆❆❆

Thành viên hoạt động

Thành viên gắn bó

Thành viên hoạt động

File đính kèm

Thành viên gắn bó

Thành viên hoạt động