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

Liên hệ QC
N

Ngô Hải Đăng

Thành viên hoạt động
Tham gia
31/8/17
Bài viết
180
Được thích
244
Donate (Paypal)
Donate
Donate (Momo)
Donate
Giới tính
Nam
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.
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
...........................
 
Lần chỉnh sửa cuối:
Upvote 0
.....................
 
Lần chỉnh sửa cuối:
Upvote 0
........................
 
Lần chỉnh sửa cuối:
Upvote 0
Upvote 0
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è ...
Nhấp chuột vào đây để mở rộng...
Đ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 ????????????
Nhấp chuột vào đây để mở rộng...
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.

1605177657797.png
 
Upvote 0
................
 
Lần chỉnh sửa cuối:
Upvote 0
ptm0412 đã viết:
mới gần đây xảy ra một vụ kiện cáo xoá bài
Nhấp chuột vào đây để mở rộng...
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 đó…

1605280721401.png

1605280724943.png

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.
1605280764695.png

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;
1605280790601.png

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

1605280890556.png

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).
 
Upvote 0
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
:D
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
 
Lần chỉnh sửa cuối:
Upvote 0
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
Đúng là thế, tuy nhiên đang tìm cách để cho nó giống giống với Office 365.
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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ấp chuột vào đây để mở rộng...
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?
 
Upvote 0
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 :-=
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

A
[Góc giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word cấu trúc giống nhau vào 1 file excel mẫu
Trả lời
1
Đọc
26
Hoàng Tuấn 868
H
T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
11
Đọc
149
VetMini
V
N
Xin code tính tổng số cấu đúng viết trong "Visual Basic" trong PPT
Trả lời
1
Đọc
4K
hahuy_hien2000
H
8
Hàm thống kê số lượng thành viên câu lạc bộ theo từng đợt tuyển thành viên
Trả lời
3
Đọc
83
HieuCD
H
LuuAnh980
Sao Filter của Excel kỳ lạ.
Trả lời
9
Đọc
93
Hoàng Tuấn 868
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom