Tập hợp HÀM TỰ TẠO để làm thư viện Hàm

Liên hệ QC

Ếch Xanh

Thành viên tích cực
Tham gia
12/8/09
Bài viết
865
Được thích
1,572
Topic này tôi mở ra mục đích là tập hợp những hàm tự tạo hay của diễn đàn, để về sau nếu ai có khả năng tổng hợp thành Addins toàn tập thì dễ dàng lấy nguồn tại đây.

Tôi cũng hy vọng, các thành viên nào có những hàm hay hoặc thấy những hàm hay trên diễn đàn Giải pháp Excel hoặc diễn đàn khác, xin vui lòng post lên đây, và vui lòng trích nguồn từ link nào để tiện theo dõi.

Bài viết này, với tôi trình độ còn yếu kém, cho nên cách đặt tên hàm cũng như cách sử dụng hàm cũng chưa chính xác, vậy xin các thành viên bổ sung, góp ý, phản biện để các hàm của chúng ta trở nên mạnh hơn, hiệu quả hơn, chất lượng hơn, nhanh hơn đặc biệt chính xác hơn.

THAM KHẢO THÊM: Mỗi ngày một hàm VBA tại đây:
http://www.giaiphapexcel.com/forum/showthread.php?31-Mỗi-tuần-một-hàm-VBA&

Dưới đây là mở đầu một vài hàm:

1) Hàm Thay đổi kích thước mảng 2 chiều (ptm0412)

PHP:
Function resizeArr(ByVal SourceArr, ByVal NewC As Long)
  Dim OldR As Long, OldC As Long, NewR As Long, iR As Long, iC As Long
  Dim ArrKQ, iKQ, jKQ, SArr
  SArr = SourceArr
  iKQ = 1: jKQ = 1
  OldR = UBound(SArr, 1)
  OldC = UBound(SArr, 2)
  NewR = Int(OldR * OldC / NewC)
  If (OldR * OldC) Mod NewC > 0 Then NewR = NewR + 1
  ReDim ArrKQ(1 To NewR, 1 To NewC)
  For iC = 1 To OldC
    For iR = 1 To OldR
      ArrKQ(iKQ, jKQ) = SArr(iR, iC)
      iKQ = iKQ + 1
      If iKQ > NewR Then iKQ = 1: jKQ = jKQ + 1
    Next
  Next
  resizeArr = ArrKQ
End Function

Nguồn: http://www.giaiphapexcel.com/forum/...về-mảng-trong-VBA-(Array)&p=309679#post309679

-------------------------------------------------------------------------------


2) Hàm SORT mảng 1 chiều: (ndu96081631)

PHP:
Function Sort1DArray(ByVal Arr, Optional ByVal isText As Boolean = False, Optional ByVal isDESC As Boolean = False)
  Dim sCommand As String
  sCommand = "('" & Join(Arr, vbBack) & "').split('" & vbBack & "').sort("
  If isText Then
    sCommand = sCommand & ")"
  Else
    sCommand = sCommand & "function(a,b){return (a-b)})"
  End If
  If isDESC Then sCommand = sCommand & ".reverse()"
    sCommand = sCommand & ".join('" & vbBack & "')"
  With CreateObject("MSScriptControl.ScriptControl")
    .Language = "JavaScript"
    Sort1DArray = Split(.Eval(sCommand), vbBack)
  End With
End Function


Nguồn: http://www.giaiphapexcel.com/forum/...về-mảng-trong-VBA-(Array)&p=320811#post320811

-------------------------------------------------------------------------------

3) Hàm tính diện tích tam giác (ndu96081631)

PHP:
Function TriArea(ByVal x1 As Double, ByVal x2 As Double, ByVal x3 As Double, _
                 ByVal y1 As Double, ByVal y2 As Double, ByVal y3 As Double) As Double
  Dim dA As Double, dB As Double, dC As Double, dP As Double
  dA = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2) '<--- Chieu dai canh A
  dB = Sqr((x3 - x2) ^ 2 + (y3 - y2) ^ 2) '<--- Chieu dai canh B
  dC = Sqr((x1 - x3) ^ 2 + (y1 - y3) ^ 2) '<--- Chieu dai canh C
  dP = (dA + dB + dC) / 2 '<--- nua chu vi
  TriArea = Sqr(dP * (dP - dA) * (dP - dB) * (dP - dC))
End Function

Nguồn: http://www.giaiphapexcel.com/forum/...khi-biết-toạ-độ-trên-exel&p=319887#post319887

CÒN TIẾP, SẼ BỔ SUNG SAU...
 
Lần chỉnh sửa cuối:
Hàm lấy dữ liệu (1 cột) không trùng (ndu96081631):

PHP:
Function UniqueList(Range As Range)
  Dim Clls As Range
  With CreateObject("Scripting.Dictionary")
    For Each Clls In Range
      If Not IsEmpty(Clls) And Not .Exists(Clls.Value) Then .Add Clls.Value, Clls.Value
    Next Clls
    UniqueList = .Keys
  End With
End Function

Cách sử dụng:

PHP:
Private Sub ComboBox1_DropButtonClick()
  With Range([A3], [A65536].End(xlUp))
    ComboBox1.List() = UniqueList(.Cells)
  End With
End Sub

Nguồn: http://www.giaiphapexcel.com/forum/showthread.php?28472-lọc-danh-sách-không-bị-trùng-tên-và-khoảng-trắng-cho-combobox-validation-list&p=192283#post192283
Cái hàm UniqueList này chưa hoàn thiện đâu!
Hàm ấy tôi viết đã lâu lắm rồi, sau này sửa lại thế này:
PHP:
Function UniqueList(ParamArray sArray())
  Dim Item, TmpArr, SubArr
  On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      TmpArr = SubArr
      If TypeName(TmpArr) <> "Variant()" Then
        If TmpArr <> "" Then .Add TmpArr, ""
      Else
        For Each Item In TmpArr
          If Item <> "" Then
            If Not .Exists(Item) Then .Add Item, ""
          End If
        Next
      End If
    Next
    UniqueList = .Keys
  End With
End Function
Hàm này hoạt động toàn bộ trên Array và cho phép tham chiếu đến nhiều vùng không liên tục
 
Lần chỉnh sửa cuối:
Upvote 0
Một số hàm mảng tự tạo (Phần I)

1./ Hàm trả về một mảng


Như chúng ta đã biết, các hàm trong excel nói chung, trong đó có cả các hàm tự tạo (UFD) thường trả về giá trị tại một ô hiện hành.

Vậy có thể có cách nào đó để một hàm tự tạo trả về là một mảng các giá trị (hiển thị trên các ô khác nhau của 1 vùng)

Lấy ví dụ: Ta dùng hàm VLOOKUP() để nó trả về phần tử đầu tiên thỏa mãn điều kiện của hàm. Tuy nhiên trong bảng tham chiếu có đến hơn vài phần tử thỏa mãn với điều kiện đó. Vậy có cách nào để nhập công thức vào một hay nhiều ô thì tất cả các kết quả thỏa điều kiện của hàm sẽ hiện ra ở các ô (kể từ ô hiện hành) hay không?

Muốn đạt mục đích này, ta xét đến hàm tự tạo sau đây dùng để giải phương trình bậc hai:
PHP:
Function PTBac2(aA As Double, bB As Double, cC As Double) 
 Dim Temp( 1 To 3): Dim DelTa As Double 

 DelTa= (bB ^ 2) - (4 * aA * cC) 
 Temp(1) = “Phuong Trinh “ 
 Select Case DelTa 
 Case Is < 0 
     Temp(1) = Temp(1) & "Vo nghiem" 
     Temp(2) = " ":             Temp(3) = " " 
 Case 0 
     Temp(1) = Temp(1) & "Mot nghiem:" 
     Temp(2) = -bB / ( 2 * aA): Temp(3) = "" 
 Case Else 
     Temp(1) = Temp(1) & "Hai nghiem:" 
     Temp(2) = (-bB + Sqr( DelTa)) / ( 2 * aA) 
     Temp(3) = (-bB - Sqr( DelTa))/(2 * aA) 
 End Select 
 PTBac2 = Temp 
End Function

Tại trang tính (“GPE”) trống nào đó, ta nhập các trị 1, 3 & -4 vô các ô tương ứng [A1], [B1] & [C1]
Sau đó dùng chuột quét chọn các ô từ [B3] đến [d3]
Tiếp theo bấm chuột lên thanh công thức và nhập cú pháp hàm
=PTBac2( A1, B1, C1)
Sau đó ta bấm tổ hợp phím giành cho hàm mảng ({CTRL}+{ATL}+{ENTER}) để nhận kết quả

Nhận xét: Các kết quả của hàm thể hiện trên cùng 1 dòng của trang tính;
Nếu giờ ta muốn thể hiện trên cùng 1 cột các kết quả này thì làm thế nào?

Lúc đó ta phải dùng đến 1 biến mảng hai chiều & hàm có nội dung được chỉnh sửa như dưới đây:
PHP:
Function PTBac2C(aA As Double, bB As Double, cC As Double) 
Dim Temp(1 To 3, 1 To 1): Dim DelTa As Double 
DelTa = (bB ^ 2) - (4 * aA * cC) 
Temp(1, 1) = "Phuong Trinh " 
Select Case DelTa 
Case Is < 0 
   Temp(1, 1) = Temp(1, 1) & "Vo nghiem" 
   Temp(2, 1) = " ":          Temp(3, 1) = " " 
Case 0 
   Temp(1, 1) = Temp(1, 1) & "Mot nghiem:" 
   Temp(2, 1) = -bB / (2 * aA): Temp(3, 1) = "" 
Case Else 
   Temp(1, 1) = Temp(1, 1) & "Hai nghiem:" 
   Temp(2, 1) = (-bB + Sqr(DelTa)) / (2 * aA) 
   Temp(3, 1) = (-bB - Sqr(DelTa)) / (2 * aA) 
End Select 
PTBac2C = Temp 
End Function

Lúc này cú pháp hàm tại các ô [B5]..[B7] sẽ fải là: =PTBac2C(A1,B1,C1- 4)

*​
* *​
*​

2./ Dùng hàm mảng tự tạo để thể hiện các nghiệm của fương trình đường tròn

Ta có bài toán: Hãy tìm các căp nghiệm của fương trình
X^2 + Y^2 = Z ^2
,với X & Y là số nguyên dương < 21

Để giải bài tập này, chúng ta nhờ tới sự hỗ trợ của hàm mảng tự tạo sau đây:

PHP:
Option Explicit:        Option Base 1 
Function DuongTron() 
 Dim Xx As Byte, Yy As Byte, Zz As Double, Dem As Byte 
 ReDim MDL(30, 3) 
 For Xx = 1 To 20 
   For Yy = 1 To 20 
      Zz = Abs((Xx ^ 2 + Yy ^ 2) ^ (1 / 2)) 
      If Int(Zz) = Zz Then 
         Dem = Dem + 1 
         MDL(Dem, 1) = Xx:       MDL(Dem, 2) = Yy 
         MDL(Dem, 3) = Zz 
      End If 
 Next Yy, Xx 
 For Xx = Dem + 1 To 30 
   MDL(Xx, 1) = "":              MDL(Xx, 2) = "" 
   MDL(Xx, 3) = "" 
 Next Xx 
 DuongTron = MDL 
End Function

Cách dùng:
Ta dùng chuột quét chọn vùng từ "G1:I16"; Ta tô màu nền cho vùng này xanh nhạt.
Sau đó, ta bấm chuột lên thanh công thức & nhập cú fáp =DuongTron()
Sau đó ta kết thúc hàm bằng tổ hợp 3 fím dành cho hàm mảng.

Rất mong các bạn thành công mĩ mãn!

*​
* *​
*​


3./ Hàm trả về tên các tập tin trong thư mục cụ thể nào đó (với đường dẫn đầy đủ):


Giả dụ chúng ta có thư mục FileSpec, và muốn liệt kê tên các tập tin trong đó lên trang tính excel, ta có thể dùng hàm mảng tự tạo như sau.
PHP:
Function FileList(FileSpec As String) As Variant 
' Returns an array of filenames that match FileSpec;' 
' If no matching files are found, it returns False.' 
    Dim FileArray() As Variant 
    Dim FileCount As Integer:             Dim FileName As String 
    On Error GoTo NoFiles 
    FileCount = 0:                        FileName = Dir(FileSpec) 
    If FileName = "" Then GoTo NoFiles 
        Loop until no more matching files are found 
    Do While FileName <> "" 
        FileCount = FileCount + 1 
        ReDim Preserve FileArray(FileCount) 
        FileArray(FileCount) = FileName 
        FileName = Dir() 
    Loop 
    FileArray(0) = FileCount 
    FileList = FileArray:                 Exit Function 
NoFiles: 
    FileList = False 
End Function

Hướng dẫn sử dụng hàm: Ta sẵn có thư mục D:\GPE\ trong máy tính; Tại vùng từ A9..K9 không chứa dữ liệu, ta có thể liệt kê các tập tin có trong có trong thư mục đó bằng cú pháp =FileList("d:\GPE\")

Cách làm cụ thể như sau:

(*) Dùng chuột tô chọn các ô vùng A9. . K9 này (Kích hoạt chúng);
(*) Bấm chuột lên thanh công thức & nhập dòng =FileList("d:\GPE\") lên nó;
(*) Sau đó nhấn tổ hợp 3 phím dành cho hàm mảng như đã đề cập bên trên.

Cần chú í thêm rằng, ô đầu tiên của hàm trả về chứa số lượng tập tin có trong thư mục đó;
Nếu tình cờ ta có số ô vừa đủ với số tập tin thì là 1 chuyện may mắn vĩ đại
Nếu ít hơn số tập tin, ta sẽ phải xóa toàn bộ (Excel không cho ta có thể xóa kết quả trong 1 vài ô của hàm mảng) & căn cứ vô số lượng tập tin ta chọn tăng số ô lên;
Nếu nhiều hơn sẽ mất mỹ quan đi 1xíu

*​
* *​
*​


4./ Trích xuất dữ liệu của 1 cá nhân theo năm sinh từ 1 danh sách trùng tên


Giả dụ cơ quan chúng ta có vài trăm nhân viên; Trong đó có một số không ít người trùng họ tên; (Xin xem bảng sau:)

G| H| I |J
TT| HoTen| NamSinh| Dvi
1| Le By| 1984| B
2 |Le My |1984 |C
3| To Ny| 1984| D
4| Do By |1985 |C
5| Ng An |1985 |A
6| To Hy |1985 |D
7| Do Na |1986 |B
8| Ng An |1986 |E
9| Le Hy |1987 |E
10| Le Na |1987 |C
11| Ng An |1987 |D
|. .| |

Nhiệm vụ sếp đề ra cho chúng ta là trích ra hồ sơ nhân viên có tên Ng An nhỏ tuổi thứ 2 trong gần chục người trùng tên đó

Để thực hiện việc này, chúc ta dùng công cụ của excel xếp dữ liệu theo cột năm sinh như trên;

Kế tiếp, ta copy hàm tự tạo sau cho vô cửa sổ VBE:
PHP:
Option Explicit 
Function DFilter(LookUpValue As String, LookUpRange As Range, _ 
   Optional Num As Byte = 1, Optional DuoiLen As Boolean = True) 
 Dim BDau As Long, KThuc As Long, Buoc As Long, jJ As Long 
 ReDim MDL(3) 
 If DuoiLen Then 
   Buoc = 1:                                 BDau = 1 
   KThuc = LookUpRange.Rows.Count 
 Else 
   BDau = LookUpRange.Rows.Count 
   Buoc = -1:                                KThuc = 1 
 End If 
 MDL(1) = LookUpValue 
 For jJ = BDau To KThuc Step Buoc 
   With LookUpRange.Cells(jJ, 2) 
      If .Value = LookUpValue Then 
         Num = Num - 1 
         If Num = 0 Then 
            MDL(2) = .Offset(, 1).Value 
            MDL(0) = .Offset(, -1).Value:    MDL(3) = .Offset(, 2).Value 
            DFilter = MDL:                   Exit Function 
         End If 
      End If 
   End With 
 Next jJ 
 If Num > 0 Then 
   MDL(0) = 0:                               MDL(2) = "Không Có Nguoi Này" 
   DFilter = MDL 
 End If 
End Function

Hướng dẫn cách dùng hàm

(*) Chọn hàng nào đó bất kỳ có trên 4 cột trống, VD 'A9:D9'
Chúng ta cũng dùng chuột kích hoạt các ô này

(*) Bấm chuột tiếp lên thanh công thức & nhập cú pháp:
=DFilter(H6,G2:J12,2)
& kết thúc bằng tổ hợp 3 phím dành cho hàm mảng để hiện kết quả

Chú ý trong cú pháp:
+ H6 là ô đang chứa tên mà chúng ta cần tìm;
+ 'G2:J12' là vùng dữ liệu mà ta yêu cầu hàm tìm trong đó (Xem như vùng dò trong VLOOKUP())
+ Tùy chọn của tham biến Num đang có trong cú pháp này có trị bằng 2, có nghĩa là tìm người nhỏ tuổi thứ 2 trong danh sách trùng tên Ng An;
Chúng ta có thể không nhập tham số này, lúc đó hàm sẽ đưa ra nhân vật đầu tiên mà nó tìm thấy;
+ Tham biến cuối chúng ta cũng bỏ qua, lúc đó hàm tự khắc biết nhiệm vụ của nó rằng phải tìm từ trên xuống;
Nếu bạn muốn hàm tìm từ dưới cùng danh sách trở lên, lúc đó ta cần nhập từ khóa 'FALSE' vô (Giống như 1 số hàm của excel cho ta tùy biến, nhỉ?!)

Chúc các bạn thành công!
 
Upvote 0
[h=2]Một số hàm mảng tự tạo (Phần I)[/h]
Mấy cái hàm mảng này e rằng phải xem lại sư phụ à!
Phương trình bậc 2 thì hơi dài. Em nghĩ có thể rút gọn lại chỉ vài dòng là đủ
--------------------------
Còn hàm lấy tên file trong thư mục thì hồi lâu lắm rồi người ta xài Dir chứ bây giờ chẳng ai xài nó cả ---> Vì nó có quá nhiều nhược điểm ---> Sư phụ cứ thử với 1 thư mục được đặt tên bằng tiếng Việt có dấu sẽ biết liền.
Chuẩn nhất là dùng Scripting.FileSystemObject hoặc lệnh DOS (cái này đã làm nhiều trên GPE rồi)
Ngoài ra, đã lấy tên file trong thư mục thì đương nhiên phải tính đến việc có lấy file trong Sub Folder hay không
 
Lần chỉnh sửa cuối:
Upvote 0
Em làm thử, mọi người kiểm tra lại giùm nhé.

Thuật toán: Sắp xếp lại các ký tự cho đúng chuẩn trước khi đưa vào hàm của anh ndu

Hàm của Thắng rất hay, tuy nhiên, hình như chỉ có 1 vấn đề ở chữ UYET65 nó rơi vào trường hợp chữ Y có dấu nặng (), Thắng thử kiểm tra lại xem nhé! Thanks.

À, kiểm thêm có chữ d9 thì thành đ nhưng D9 không ra Đ mà vẫn là D, và hầu như chỉ chuyển chữ thường, các chữ hoa không chuyển đổi.
 
Lần chỉnh sửa cuối:
Upvote 0
Em làm thử, mọi người kiểm tra lại giùm nhé.

Thuật toán: Sắp xếp lại các ký tự cho đúng chuẩn trước khi đưa vào hàm của anh ndu

Em test thử code trên win 8 64bit thì nó báo lỗi anh ah:

1) TestTelex:


2) TestVNI:


Lâu rồi không thấy các Thầy và các anh chị update thêm các hàm tự tạo.
Đề tài hay mong mọi các Thầy và các anh chị update thêm ạ!
 
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
Hàm chuyển chuỗi unicode về ký tự bàn phím kiểu gõ Telex?

Hàm chuyển chuỗi unicode về ký tự bàn phím kiểu gõ Telex?

Mình muốn trên bảng tính gõ:
=KyTuTelexTuUnicode("Công cụ tuyệt vời") Hàm trả về
"Coong cuj tuyeetj vowif"

Không biết trên GPE đã có hàm này chưa?
 
Upvote 0
Upvote 0
Hàm tách chữ

Em xin đóng góp hàm cùi bắp này:
PHP:
Function SplitWord(Str As String, C As String, VT As Long, Optional Words As Long = 1, Optional Op As Boolean = False) As String
Dim Arr As Variant, i As Long
If Op Then Str = StrReverse(Str): C = StrReverse(C)
Arr = Split(Str, C)
For i = VT To Application.WorksheetFunction.Min(VT + Words - 1, UBound(Arr) + 1)
    SplitWord = SplitWord & C & Arr(i - 1)
Next
SplitWord = Replace(SplitWord, C, "", 1, 1)
If Op Then SplitWord = StrReverse(SplitWord)
End Function
Dùng để tách chữ với nhiều tùy chọn.
Cú pháp:
Mã:
=SplitWord(Chuỗi_cần_tách, Chuỗi_phân_cách, Vị_trí_bắt_đầu, [Số_từ_cần_lấy], [Xuôi_hay_ngược])
Mã:
=SplitWord(Chuỗi_cần_tách, Chuỗi_phân_cách, Vị_trí_bắt_đầu, [Số_từ_cần_lấy], [Xuôi_hay_ngược])
[/CODE]
Anh cho em hỏi [Xuôi_hay_ngược] có nghĩa là sao ạ? anh diễn giải rõ hơn giúp em mới nhé!
 
Upvote 0
Mã:
=SplitWord(Chuỗi_cần_tách, Chuỗi_phân_cách, Vị_trí_bắt_đầu, [Số_từ_cần_lấy], [Xuôi_hay_ngược])
[/CODE]
Anh cho em hỏi [Xuôi_hay_ngược] có nghĩa là sao ạ? anh diễn giải rõ hơn giúp em mới nhé!
Xuôi là tính từ trái sang phải, ngược là tính từ phải sang trái. Mặc định là xuôi (False)
Ví dụ công thức lấy tên trong họ tên sẽ là:
Mã:
=SplitWord(A1," ",1,1,True)
Lấy 2 chữ cuối trong họ tên:
Mã:
=SplitWord(A1," ",1,2,True)
 
Upvote 0
Web KT

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

Back
Top Bottom