Làm Sao Gán Kết Qủa Xuống Từng Dòng Bằng Hàm Tự Tạo

Liên hệ QC

langkhachquaduong

Thành viên chính thức
Tham gia
23/7/19
Bài viết
50
Được thích
8
Mình có 1 hàm unique để lọc dữ liệu duy nhất.
Làm cách để khi ta gõ hàm unique vào ô b1 , kết qủa unique là 10 giá trị thì tự động hàm unique gán giá trị xuống ô b1 đến b10.
 

File đính kèm

  • unique.xlsm
    17.8 KB · Đọc: 39
Mình có 1 hàm unique để lọc dữ liệu duy nhất.
Làm cách để khi ta gõ hàm unique vào ô b1 , kết qủa unique là 10 giá trị thì tự động hàm unique gán giá trị xuống ô b1 đến b10.
Dùng thủ tục đi, hàm sao làm được. Hoặc dùng chức năng Consolidate có sẵn trong Excel cũng được mà
 
Lần chỉnh sửa cuối:
Upvote 0
Trên nguyên tắc, hàm tự tạo không thể sửa đổi gì trên bảng tính.
Yêu cầu "gán kết quả xuống ... bằng hàm tự tạo" coi như không thể thực hiện.

(thực ra có cách để "che mắt" Excel và gán được. Nhưng cách đó chỉ những người tin rằng mình đã đạt tình độ cao của VBA mới nên dùng. Ai muôn thì tự tìm lấyn đi. tôi không nói thêm ở đây)
 
Upvote 0
Mình có 1 hàm unique để lọc dữ liệu duy nhất.
Làm cách để khi ta gõ hàm unique vào ô b1 , kết qủa unique là 10 giá trị thì tự động hàm unique gán giá trị xuống ô b1 đến b10.
Nếu bạn dùng phiên bản office 365 thì thậm chí bạn không cần làm gì cả, tự nhiên nó được vậy thôi

 
Upvote 0
Nếu không có 365 thì xài tạm cái này:
PHP:
Function UNIQUE(Rng As Range)
 Dim Arr As Variant, Cls As Range
 Dim J As Long, K As Long, W As Long
 Dim dic As Object

 Set dic = CreateObject("Scripting.Dictionary")
 ReDim Arr(1 To 2 * Rng.Cells.Count, 1 To 1)
 For Each Cls In Rng
    J = J + 1
    If Not dic.exists(Cls.Value) Then
        dic.Add Cls.Value, J
        W = W + 1:              Arr(W, 1) = Str(Cls.Value)
    End If
 Next
 UNIQUE = Arr()
End Function
 
Upvote 0
Nếu không có 365 thì xài tạm cái này:
PHP:
Function UNIQUE(Rng As Range)
Dim Arr As Variant, Cls As Range
Dim J As Long, K As Long, W As Long
Dim dic As Object

Set dic = CreateObject("Scripting.Dictionary")
ReDim Arr(1 To 2 * Rng.Cells.Count, 1 To 1)
For Each Cls In Rng
    J = J + 1
    If Not dic.exists(Cls.Value) Then
        dic.Add Cls.Value, J
        W = W + 1:              Arr(W, 1) = Str(Cls.Value)
    End If
Next
UNIQUE = Arr()
End Function
Không phải vậy đâu sư phụ à. Ý người ta là làm sao cho nó tự động fill công thức mảng kìa. Như trong video, em gõ công thức vào 1 cell, enter phát là nó tự fill xuống đến hết mà không cần phải quét chọn trước vùng chứa kết quả (mà dù có quét cũng không biết phải quét bao nhiêu ô là đủ)
 
Upvote 0
Nếu không có 365 thì xài tạm cái này:
...
Loại hàm mảng này tôi đã từng giải thíchn cách dùng rồi.
Gõ =Rows(Hàm UDF(...))
Nó ra số gì thì bôi đen bao nhiêu ấy ô, gõ hàm và nhấn Ctrl+Enter

Lưu ý là hàm phải trả về mảng với nhiều dòng và một cột. Nếu hàm trả về một dòng thì phải thêm hàm transpose hoặc fill ngang
 
Upvote 0
Mình có 1 hàm unique để lọc dữ liệu duy nhất.
Làm cách để khi ta gõ hàm unique vào ô b1 , kết qủa unique là 10 giá trị thì tự động hàm unique gán giá trị xuống ô b1 đến b10.
Chắc là ý như Video ... VBA thừa sức viết ra và không xài tới API của Bill
Cố giắng mò xem sao nha ... Nếu kẹt quá thì xài Office 365 đi cho khỏe
 
Lần chỉnh sửa cuối:
Upvote 0
Mình có 1 hàm unique để lọc dữ liệu duy nhất.
Làm cách để khi ta gõ hàm unique vào ô b1 , kết qủa unique là 10 giá trị thì tự động hàm unique gán giá trị xuống ô b1 đến b10.
Tìm trên diễn đàn nha, trước đây mình có làm thử theo file trên diễn đàn, chạy chậm quá nên xóa mất
 
Upvote 0
Mình có 1 hàm unique để lọc dữ liệu duy nhất.
Làm cách để khi ta gõ hàm unique vào ô b1 , kết qủa unique là 10 giá trị thì tự động hàm unique gán giá trị xuống ô b1 đến b10.
Bạn kiểm tra thử xem,

Bỏ đoạn này vào ThisWorkbook module:
Mã:
Option Explicit
Public RangesToExpand As New Collection
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim oneCell As Range
    Dim strFormula
    Application.EnableEvents = False
    For Each oneCell In RangesToExpand
        With oneCell
            strFormula = .Cells(1, 1).FormulaArray
            .CurrentRegion.ClearContents
            .FormulaArray = strFormula
            RangesToExpand.Remove .Address(, , , True)
        End With
    Next oneCell
    Application.EnableEvents = True
End Sub

Bỏ đoạn này vào Module có tên "FUNCUNIQUE" hoặc một module mới.
Mã:
Function UNIQUES_COL(rng As Range) As Variant()
    Dim list As New Collection
    Dim Ulist() As Variant
    Dim Value, i As Long
    On Error Resume Next
    For Each Value In rng
        list.Add CStr(Value), CStr(Value)
    Next
    On Error GoTo 0
    ReDim Ulist(list.Count - 1, 0)
    For i = 0 To list.Count - 1
        Ulist(i, 0) = list(i + 1)
    Next
    If TypeName(Application.Caller) = "Range" Then
        If Application.EnableEvents Then
            With Application.Caller
                If .Rows.Count <> i Or .Columns.Count <> 1 Then

                    If ThisWorkbook.RangesToExpand Is Nothing Then
                        Set ThisWorkbook.RangesToExpand = New Collection
                    End If

                    With .Resize(i, 1)
                        ThisWorkbook.RangesToExpand.Add item:=.Cells, Key:=.Address(, , , True)
                    End With

                End If
            End With
        End If
    End If
    UNIQUES_COL = Ulist
End Function

Gõ vào F1:
Mã:
=UNIQUES_COL($A$1:$A$13)
 

File đính kèm

  • unique.xlsm
    21.6 KB · Đọc: 36
Upvote 0
Rảnh mới thử làm cái hàm chuyển mảng xem sao ... cơ bản là chạy tốt và quan trọng nhất là viết code tính toán như thế nào ??!!!
Còn lại cái Hàm gán lên Sheet Kiểu office 365 là xong ............ xài chung cho tất cả các hàm khác nhau ....
đại ý như sau
Mã:
TransposeArray = ResizeArray(Total)
Cái khó nhất là cái Hàm ResizeArray ................. xài chung cho tất cả các Hàm gán kết quả lên Sheet kiểu office 365

 
Lần chỉnh sửa cuối:
Upvote 0
Xài 365 nói làm gì nữa.Nó tích sẵn luôn rồi bỏ tiền ra mua thôi.
Mình đang tự viết hàm giống với unique nhưng đến đoạn đỗ ra range thì chưa biết phải làm gì
Bài đã được tự động gộp:

Bạn kiểm tra thử xem,

Bỏ đoạn này vào ThisWorkbook module:
Mã:
Option Explicit
Public RangesToExpand As New Collection
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Dim oneCell As Range
    Dim strFormula
    Application.EnableEvents = False
    For Each oneCell In RangesToExpand
        With oneCell
            strFormula = .Cells(1, 1).FormulaArray
            .CurrentRegion.ClearContents
            .FormulaArray = strFormula
            RangesToExpand.Remove .Address(, , , True)
        End With
    Next oneCell
    Application.EnableEvents = True
End Sub

Bỏ đoạn này vào Module có tên "FUNCUNIQUE" hoặc một module mới.
Mã:
Function UNIQUES_COL(rng As Range) As Variant()
    Dim list As New Collection
    Dim Ulist() As Variant
    Dim Value, i As Long
    On Error Resume Next
    For Each Value In rng
        list.Add CStr(Value), CStr(Value)
    Next
    On Error GoTo 0
    ReDim Ulist(list.Count - 1, 0)
    For i = 0 To list.Count - 1
        Ulist(i, 0) = list(i + 1)
    Next
    If TypeName(Application.Caller) = "Range" Then
        If Application.EnableEvents Then
            With Application.Caller
                If .Rows.Count <> i Or .Columns.Count <> 1 Then

                    If ThisWorkbook.RangesToExpand Is Nothing Then
                        Set ThisWorkbook.RangesToExpand = New Collection
                    End If

                    With .Resize(i, 1)
                        ThisWorkbook.RangesToExpand.Add item:=.Cells, Key:=.Address(, , , True)
                    End With

                End If
            End With
        End If
    End If
    UNIQUES_COL = Ulist
End Function

Gõ vào F1:
Mã:
=UNIQUES_COL($A$1:$A$13)
Mình đã text thử ok đó.
Bài đã được tự động gộp:

Tìm trên diễn đàn nha, trước đây mình có làm thử theo file trên diễn đàn, chạy chậm quá nên xóa mất
Bác nhớ từ khóa tên gì không em muốn kham khảo.
 
Upvote 0
Nếu bạn không có Office 365 hoặc muốn tính năng hàm tự insert dòng, hoặc hết tất cả các cách rồi thì tham khảo giải pháp cuối cùng là dùng hàm BS_UNIQUE của Add-in A-Tools
 
Upvote 0
Các Bạn cố giắng mà học cách điền kết quả ra Sheet kiểu Office 365 đi sẻ rất hay đấy ... Ngay cả khi Bạn xài Office 365 mà một số hàm Bill không hổ trợ thì viết lấy mà xài cho khỏe VD như: xài ADO lấy dữ liệu file Access Or Excel thì viết ADO bình thường như những hàm khác xong truyền SQL vào gõ trên Cells cái cộp là xong .... Minh họa như hình sau ( làm biếng úp Video lắm )

Nếu kẹt nữa thì Atools cũng là 1 giải pháp tốt cho Bạn :D

1601255872627.png
 
Lần chỉnh sửa cuối:
Upvote 0
Trong Excel 365 thì hàm Unique nó tự động điền xuống dưới luôn, bí lắm thớt chuyển qua 365 xài cho khỏe
 
Upvote 0
Trong Excel 365 thì hàm Unique nó tự động điền xuống dưới luôn, không cần phải quét chọn toàn bộ ô trước khi gõ hàm.
xem video bài số 4 Anh ý xài 365 đấy không quét chọn đối số của hàm thì chỉ có nước gõ vào thôi bạn ợ
 
Upvote 0
Upvote 0
Web KT
Back
Top Bottom