Tập hợp HÀM TỰ TẠO để làm thư viện Hàm
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.
Khóa học Power PI – Ứng dung trong Nhân sự
TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...
Xem khóa học
Hàm nội suy 1 chiều cho cả ngang và dọc (Ptm0412):
Option Base 1
Function Noisuy(XNum As Double, XRng As Range, YRng As Range) As Double
If XNum = 0 Then Noisuy = 0: Exit Function
Dim KnownX, KnownY, i, k
k = 1
ReDim KnownX(1 To XRng.Count)
ReDim KnownY(1 To XRng.Count)
For Each Cll In XRng
KnownX(k) = Cll.Value
k = k + 1
Next
k = 1
For Each Cll In YRng
KnownY(k) = Cll.Value
k = k + 1
Next
For i = 1 To XRng.Count
If KnownX(i) <= XNum And KnownX(i + 1) >= XNum Then
Noisuy = KnownY(i) + ((XNum – KnownX(i)) * _
(KnownY(i + 1) – KnownY(i))) / (KnownX(i + 1) – KnownX(i))
Exit Function
End If
Next
End Function
Bạn có thể rút gọn và tổng quát các trường hợp hơn không? Cám ơn bạn.
Câu lệnh:
này hoàn toàn đúng trong phạm vi yêu cầu của đề bài.
Nó đã thoả mãn điều kiện khi dự án <= 5 tỷ thì chi phí này sẽ là 0.64%
Thế 0.64% * 0 = ? ; cần gì xét nữa.
Mình nghĩ rằng code (cùng một người viết) càng dài thì càng tổng quát vì người viết đã xét nhiều trường hợp, và chương trình chạy càng nhanh.
Ở trên tôi có nói: nếu cần tổng quát thì xóa bỏ dòng lệnh If XNum = 0 Then Noisuy = 0: Exit Function
Và tôi cũng có nói: Hàm này có thể tính cho 2 vùng dữ liệu cả ngang và dọc, ở vị trí bất kỳ, theo ý bạn cũng vẫn chưa gọi là tổng quát, vậy thế nào có thể gọi là tổng quát?
Tiêu đề "hàm nội suy" là sai, vậy "hàm nội suy" thật sự đúng nó như thế nào? Bạn có thể cho biết không?
Nhân tiện, xin nhờ bạn và các cao thủ góp ý và viết cho 1 hàm "nội suy" thật sự đúng và thật sự tổng quát.
Xin cám ơn.
Hàm tính bảng chấm công (Sa_DQ):
Option Explicit
Function THCong(Cong As Range, LCg As String) As Variant
Dim Cls As Range: Const DC As String = "/"
For Each Cls In Cong
Select Case UCase(LCg)
Case "X"
If Weekday(Cells(7, Cls.Column).Value) > 1 Then
If UCase(Left(Cls.Value, 1)) = "X" Then
THCong = THCong + 1
ElseIf Cls.Value = "1/2" Then
THCong = THCong + 0.5
End If
End If
Case "P", "KP", "O", "L"
13 If UCase(Cls.Value) = "P" And LCg = "P" Then THCong = THCong + 1
If UCase(Cls.Value) = "KP" And LCg = "KP" Then THCong = THCong + 1
15 If UCase(Cls.Value) = "O" And LCg = "O" Then THCong = THCong + 1
If UCase(Cls.Value) = "L" And LCg = "L" Then THCong = THCong + 1
Case "TG"
If Weekday(Cells(7, Cls.Column).Value) = 1 Then
If UCase(Cls.Value) = "X" Then
THCong = THCong + 1
ElseIf Cls.Value = "1/2" Then
THCong = THCong + 0.5
End If
End If
Case "TC"
On Error Resume Next
If Len(Cls.Value) >= 2 And InStr(Cls.Value, DC) < 1 Then
THCong = THCong + CDbl(Right(Cls.Value, 1))
End If
End Select
Next Cls
End Function
Nguồn: https://www.giaiphapexcel.com/forum/showthread.php?51363-(àm-tự-tạo-để-tổng-hợp-các-loại-công-dị-thường.&p=324663#post324663
Hàm kiểm tra khối ô có chứa Merge Cells hay không (minhthien321):
Function MergeCheck(Rng As Range) As Boolean
On Error GoTo MerCls
MergeCheck = Rng.MergeCells: Exit Function
MerCls:
MergeCheck = True
End Function
Thủ tục dưới đây làm cho khối ô Merge hoặc UnMerge:
Sub MergeAndUnMerge()
With Selection
If MergeCheck(Selection) = True Then
.UnMerge: .HorizontalAlignment = xlGeneral
Else
.Merge: .HorizontalAlignment = xlCenter
End If
End With
End Sub
Nói thêm là, tại sao ta làm cái thủ tục này, bởi vì có những lúc ta ProtectSheet mà đã bảo vệ thì Excel lại không cho Merge Cells, vì vậy nếu muốn sử dụng thủ tục này, đầu thủ tục ta cho UnProtect trước, cuối thủ tục ta lại Protect nó lại.
Hàm lấy tên cột từ chỉ số cột trong Excel
Nhớ có lần thầy NDU có hướng dẫn về vụ này như sau:
Function ColLetter(ByVal Cel As Range) As String
ColLetter = Replace(Cells(1, Cel.Column).Address(0, 0), 1, "")
End Function
Không biết có phải ý thầy là vậy?
Tức là thế này:
– Với hàm của anh, nếu em gõ vào bảng tính công thức =CotABC(100) thì nó sẽ cho kết quả = CV, đúng không?
– Giả định em muốn biết cột hiện hành là tên gì thì làm sao? Em đang đứng ở cột CV, làm sao em biết cột này có số thứ tự =100 để mà điền vào hàm đây?
– Vậy sẽ cải tiến lại hàm sao cho nếu em gõ =CotABC() không có đối số thì ngầm định là đang nói đến cột tại ActiveCell
—————
Em nghĩ sửa thành vầy sẽ ổn hơn:
Function CotABC(Optional ColIndex) As String
If IsMissing(ColIndex) Then ColIndex = Application.ThisCell.Column
CotABC = Replace(Cells(1, ColIndex).Address(0, 0), 1, "")
End Function
Lỗi gì ta? Các bạn khác kiểm tra giúp
ActiveCell khác ThisCell nha anh
Anh có thể thí nghiệm bằng cách thêm Application.Volatile vào đầu code như thế này:
Function CotABC(Optional ColIndex) As String
Application.Volatile
If IsMissing(ColIndex) Then ColIndex = ActiveCell.Column
CotABC = Replace(Cells(1, ColIndex).Address(0, 0), 1, "")
End Function
Xong, tại cell F1, anh gõ =CotABC() —> Đương nhiên kết quả sẽ = chữ F
Thế nhưng khi anh di chuyển chuột sang 1 cell khác rồi bấm F9, nhìn lại kết quả ở F1, anh thấy gì nè?
Ẹc… Ẹc…
Thí nghiệm vầy xem
Function CotABC(Optional Col) As String
Dim Tmp As Long
On Error Resume Next
If IsMissing(Col) Then
Tmp = Application.ThisCell.Column
ElseIf TypeName(Col) = "Range" Then
Tmp = Col.Column
Else
Tmp = Col
End If
CotABC = Replace(Cells(1, Tmp).Address(0, 0), 1, "")
End Function
=======
Trường hợp này nếu ta viết CotABC(A1) thì nó sẽ hiểu A1 là Range (không lấy giá trị tại A1). Còn nếu viết vầy CotABC(Value(A1)) thì nó sẽ thế giá trị 2 của A1 vào công thức
Hàm tách chữ
Em xin đóng góp hàm cùi bắp này:
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ình hỏi tí: Cái này dùng để làm gì? Theo mình hiểu thì khi muốn đưa chuổi "Giải Pháp Excel – Công cụ tuyệt vời của bạn" vào VBA, đầu tiên bạn phải gõ chuổi này vào đâu đó (trên bảng tính chẳng hạn), lấy kết quả xong mới đưa được vào VBA, đúng không?
Vậy thì.. cực quá…
Tôi dùng hàm này:
Function UniConvert(Text As String, InputMethod As String) As String
Dim VNI_Type, Telex_Type, CharCode, Temp, i As Long
UniConvert = Text
VNI_Type = Array("a81", "a82", "a83", "a84", "a85", "a61", "a62", "a63", "a64", "a65", "e61", _
"e62", "e63", "e64", "e65", "o61", "o62", "o63", "o64", "o65", "o71", "o72", "o73", "o74", _
"o75", "u71", "u72", "u73", "u74", "u75", "a1", "a2", "a3", "a4", "a5", "a8", "a6", "d9", _
"e1", "e2", "e3", "e4", "e5", "e6", "i1", "i2", "i3", "i4", "i5", "o1", "o2", "o3", "o4", _
"o5", "o6", "o7", "u1", "u2", "u3", "u4", "u5", "u7", "y1", "y2", "y3", "y4", "y5")
Telex_Type = Array("aws", "awf", "awr", "awx", "awj", "aas", "aaf", "aar", "aax", "aaj", "ees", _
"eef", "eer", "eex", "eej", "oos", "oof", "oor", "oox", "ooj", "ows", "owf", "owr", "owx", _
"owj", "uws", "uwf", "uwr", "uwx", "uwj", "as", "af", "ar", "ax", "aj", "aw", "aa", "dd", _
"es", "ef", "er", "ex", "ej", "ee", "is", "if", "ir", "ix", "ij", "os", "of", "or", "ox", _
"oj", "oo", "ow", "us", "uf", "ur", "ux", "uj", "uw", "ys", "yf", "yr", "yx", "yj")
CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
ChrW(7849), ChrW(7851), ChrW(7853), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), ChrW(7899), ChrW(7901), ChrW(7903), _
ChrW(7905), ChrW(7907), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), ChrW(7921), ChrW(225), _
ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), ChrW(259), ChrW(226), ChrW(273), ChrW(233), ChrW(232), _
ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), ChrW(7881), ChrW(297), ChrW(7883), _
ChrW(243), ChrW(242), ChrW(7887), ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(250), ChrW(249), _
ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
Select Case InputMethod
Case Is = "VNI": Temp = VNI_Type
Case Is = "Telex": Temp = Telex_Type
End Select
For i = 0 To UBound(CharCode)
UniConvert = Replace(UniConvert, Temp(i), CharCode(i))
UniConvert = Replace(UniConvert, UCase(Temp(i)), UCase(CharCode(i)))
Next i
End Function
Gõ trực tiếp vào VBA luôn. Ví dụ:
Sub TestVNI()
Dim Text As String
Text = "Gia3i pha1p Excel – Co6ng cu5 tuye65t vo72i cu3a ba5n"
Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "VNI") & """,2)")
End Sub
Hoặc
Sub TestTelex()
Dim Text As String
Text = "Giari phasp Excel – Coong cuj tuyeejt vowfi cura bajn"
Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "Telex") & """,2)")
End Sub
Tôi cũng đang có tham vọng sẽ viết hàm ở mức tổng quát hơn, tức cho phép gõ dấu tự do, nhưng tạm thời vẫn chưa nghĩ được giải thuật tối ưu —> Hay là Thắng giúp 1 tay để hoàn thiện đi
Thì hàm tự tạo nào cũng vậy mà, đâu riêng gì hàm của tôi. Vấn đề là nó giúp ta đở cực công với mấy cái ChrW(…) gì gì đó là khỏe rồi
Tôi chỉ ngại suy nghĩ 1 thuật toán tổng quát thôi chứ còn áp dụng thì rất dễ
Ví dụ chuổi "Ba5n chu7a nha65p gia1 tri5 cho y1" tôi sẽ không làm như trên, cái nào không cần convert thì chẳng việc gì phải cho vào hàm Convert, đúng không?
(đã đưa vào hàm là ý muốn nó "dịch" cơ mà)
Ví dụ code trên tôi viết thế này:
Sub TestVNI()
Dim Text As String
Text = "Ba5n chu7a nha65p gia1 tri5 cho"
Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "VNI") & " y1"",2)")
End Sub
—————–
Unikey đã làm được cái việc gõ dấu tự do đấy thôi! Tức 1 thuật toán tính toán cho việc gõ dấu tự do là hoàn toàn khả thi (chỉ tại mình suy nghĩ chưa ra thôi)
Ngoài ra, nếu tôi nhớ không lầm thì trên GPE đã từng có ai đó làm việc này rồi thì phải
Em làm thử, mọi người kiểm tra lại giùm nhé.
Function UniConvert(ByVal Text As String, ByVal InputMethod As String) As String
Dim VNI_Type, Telex_Type, CharCode, Temp, i As Long
UniConvert = SapXepChuoi(Text, InputMethod)
VNI_Type = Array("a81", "a82", "a83", "a84", "a85", "a61", "a62", "a63", "a64", "a65", "e61", _
"e62", "e63", "e64", "e65", "o61", "o62", "o63", "o64", "o65", "o71", "o72", "o73", "o74", _
"o75", "u71", "u72", "u73", "u74", "u75", "a1", "a2", "a3", "a4", "a5", "a8", "a6", "d9", _
"e1", "e2", "e3", "e4", "e5", "e6", "i1", "i2", "i3", "i4", "i5", "o1", "o2", "o3", "o4", _
"o5", "o6", "o7", "u1", "u2", "u3", "u4", "u5", "u7", "y1", "y2", "y3", "y4", "y5")
Telex_Type = Array("aws", "awf", "awr", "awx", "awj", "aas", "aaf", "aar", "aax", "aaj", "ees", _
"eef", "eer", "eex", "eej", "oos", "oof", "oor", "oox", "ooj", "ows", "owf", "owr", "owx", _
"owj", "uws", "uwf", "uwr", "uwx", "uwj", "as", "af", "ar", "ax", "aj", "aw", "aa", "dd", _
"es", "ef", "er", "ex", "ej", "ee", "is", "if", "ir", "ix", "ij", "os", "of", "or", "ox", _
"oj", "oo", "ow", "us", "uf", "ur", "ux", "uj", "uw", "ys", "yf", "yr", "yx", "yj")
CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
ChrW(7849), ChrW(7851), ChrW(7853), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), ChrW(7899), ChrW(7901), ChrW(7903), _
ChrW(7905), ChrW(7907), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), ChrW(7921), ChrW(225), _
ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), ChrW(259), ChrW(226), ChrW(273), ChrW(233), ChrW(232), _
ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), ChrW(7881), ChrW(297), ChrW(7883), _
ChrW(243), ChrW(242), ChrW(7887), ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(250), ChrW(249), _
ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
Select Case InputMethod
Case Is = "VNI": Temp = VNI_Type
Case Is = "Telex": Temp = Telex_Type
End Select
For i = 0 To UBound(CharCode)
UniConvert = Replace(UniConvert, Temp(i), CharCode(i))
UniConvert = Replace(UniConvert, UCase(Temp(i)), UCase(CharCode(i)))
Next i
End Function
Sub TestTelex()
Dim Text As String
Text = "Giair phaps Excel – Coong cuj tuyeetj vowif cuar banj"
Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "Telex") & """,2)")
End Sub
Sub TestVNI()
Dim Text As String
Text = "Giai3 phap1 Excel – Co6ng cu5 tuye6t5 vo7i2 cua3 ban5"
Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "VNI") & """,2)")
End Sub
Private Function ChuyenDoiTuTelex(ByVal Tu As String) As String
Dim NguyenAmChinh As String, NguyenAm As String, ViTriNguyenAm As Long, Dau As String, i As Long
For i = 1 To Len(Tu)
If InStr("ueoaiy", Mid(Tu, i, 1)) Then
If ViTriNguyenAm = 0 Then ViTriNguyenAm = i
NguyenAm = NguyenAm & Mid(Tu, i, 1)
End If
Next
If NguyenAm = "" Then
ChuyenDoiTuTelex = Tu
Exit Function
End If
For i = 1 To 5
If InStr(Tu, Mid("sfrxj", i, 1)) > ViTriNguyenAm Then Dau = Mid("sfrxj", i, 1)
Next
If Len(NguyenAm) = 3 Then
NguyenAmChinh = Mid(NguyenAm, 2, 1)
ElseIf NguyenAm = "uo" Or NguyenAm = "ou" Then
NguyenAmChinh = "o"
ElseIf InStr(NguyenAm, "e") Then
NguyenAmChinh = "e"
Else
NguyenAmChinh = Left(NguyenAm, 1)
End If
If Dau <> "" Then
Tu = Replace(Tu, NguyenAmChinh, NguyenAmChinh & Dau)
Tu = Left(Tu, InStr(Tu, NguyenAmChinh) + 1) & Replace(Tu, Dau, "", InStr(Tu, NguyenAmChinh) + 2)
End If
For i = 1 To 4
If Len(Tu) – Len(Replace(Tu, Mid("daeo", i, 1), "")) = 2 Then
Tu = Replace(Tu, Mid("daeo", i, 1), String(2, Mid("daeo", i, 1)))
Tu = Left(Tu, InStr(Tu, Mid("daeo", i, 1)) + 1) & Replace(Tu, Mid("daeo", i, 1), "", InStr(Tu, Mid("daeo", i, 1)) + 2)
End If
Next
If InStr(Tu, "w") Then
Tu = Replace(Tu, "w", "")
For i = 1 To 3
Tu = Replace(Tu, Mid("aou", i, 1), Mid("aou", i, 1) & "w")
Next
End If
ChuyenDoiTuTelex = Tu
End Function
Private Function ChuyenDoiTuVNI(ByVal Tu As String) As String
Dim NguyenAmChinh As String, NguyenAm As String, ViTriNguyenAm As Long, Dau As String, i As Long
For i = 1 To Len(Tu)
If InStr("ueoaiy", Mid(Tu, i, 1)) Then
If ViTriNguyenAm = 0 Then ViTriNguyenAm = i
NguyenAm = NguyenAm & Mid(Tu, i, 1)
End If
Next
If NguyenAm = "" Then
ChuyenDoiTuVNI = Tu
Exit Function
End If
For i = 1 To 5
If InStr(Tu, CStr(i)) > ViTriNguyenAm Then Dau = CStr(i)
Next
If Len(NguyenAm) = 3 Then
NguyenAmChinh = Mid(NguyenAm, 2, 1)
ElseIf NguyenAm = "uo" Or NguyenAm = "ou" Then
NguyenAmChinh = "o"
ElseIf InStr(NguyenAm, "e") Then
NguyenAmChinh = "e"
Else
NguyenAmChinh = Left(NguyenAm, 1)
End If
If Dau <> "" Then
Tu = Replace(Tu, Dau, "")
Tu = Replace(Tu, NguyenAmChinh, NguyenAmChinh & Dau)
End If
If InStr(Tu, "9") Then
Tu = Replace(Tu, "9", "")
Tu = Replace(Tu, "d", "d9")
End If
If InStr(Tu, "8") Then
Tu = Replace(Tu, "8", "")
Tu = Replace(Tu, "a", "a8")
End If
If InStr(Tu, "7") Then
Tu = Replace(Tu, "7", "")
Tu = Replace(Tu, "o", "o7")
Tu = Replace(Tu, "u", "u7")
End If
If InStr(Tu, "6") Then
Tu = Replace(Tu, "6", "")
Tu = Replace(Tu, "a", "a6")
Tu = Replace(Tu, "e", "e6")
Tu = Replace(Tu, "o", "o6")
End If
ChuyenDoiTuVNI = Tu
End Function
Function SapXepChuoi(ByVal Chuoi As String, ByVal InputMethod As String) As String
Dim Arr As Variant, i As Long
Arr = Split(Chuoi, " ")
Select Case InputMethod
Case "Telex"
For i = 0 To UBound(Arr)
Arr(i) = ChuyenDoiTuTelex(Arr(i))
Next
Case "VNI"
For i = 0 To UBound(Arr)
Arr(i) = ChuyenDoiTuVNI(Arr(i))
Next
End Select
SapXepChuoi = Join(Arr, " ")
End Function
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
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à:
Lấy 2 chữ cuối trong họ tên:
Hàm lấy dữ liệu (1 cột) không trùng (ndu96081631):
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:
Private Sub ComboBox1_DropButtonClick()
With Range(, .End(xlUp))
ComboBox1.List() = UniqueList(.Cells)
End With
End Sub
Nguồn: https://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
Hàm tạo dãy số ngẫu nhiên không trùng (anhtuan1066):
Function UniqueRandomNum(Bottom As Long, Top As Long, Amount As Long)
'Application.Volatile '<— Neu muon gia tri thay doi khi bam F9
On Error Resume Next
If Amount > Top – Bottom + 1 Then Amount = Top – Bottom + 1
With CreateObject("Scripting.Dictionary")
Do
.Add Int(Rnd() * (Top – Bottom + 1)) + Bottom, ""
Loop Until .Count = Amount
UniqueRandomNum = WorksheetFunction.Transpose(.Keys)
End With
End Function
Cách sử dụng:
=UniqueRandomNum(Số nhỏ, Số lớn, bao nhiêu số cần tạo)
Nguồn: https://www.giaiphapexcel.com/forum/showthread.php?27286-Tạo-dãy-số-ngẫu-nhiên-không-trùng&p=184501#post184501
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:
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 , &
Sau đó dùng chuột quét chọn các ô từ đến
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:
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 ô .. 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:
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.
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:
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ỉ?!)
Hàm tìm vị trí của ký tự "trắng" thứ n của 1 chuỗi
Ừm! Lam_A0 thân.
Chẳng có gì đâu. Một hôm mình nghĩ rằng cần tạo ra cái hàm để tìm ký tự "trắng" cuối cùng trong 1 chuỗi (để có thể ứng dụng vào việc tách tên ra khỏi họ tên) mình gọi là ham RONG() (rỗng ấy mà!):
(kết hợp với hàm MID, sẽ tách được tên ra khỏi họ và tên)
Thế rồi, mình nghĩ nếu tách cả họ riêng, tách tên lót riêng nữa thì hay biết mấy, mình nghĩ : Thử làm thêm cái RONGA(s,n) này. Mình thử kết hợp vào để tách mỗi thứ 1 cái thì thấy: Ờ, cũng được – Tuy có vẻ hơi rừng, không chuyên nghiệp lắm đâu.
Bên cạnh đó, có thể dùng để ứng dụng một số việc khác cũng thấy đường được,… ừ thì giới thiệu rồi các bạn trên diễn đàn góp ý cho câu cú, kể cả giải thuật nữa cho gọn gọn, dễ hiểu ấy mà.
Thân.
Ứng dụng hàm này liên quan đến việc lấy nhanh dữ liệu trong 1 hàng chữ (string) khi dãy chữ có 1 thứ tự giống nhau & ta biết vị trí của phần dữ liệu cần lấy trong đó.
Chẳng hạn như khi nhập data từ txt/rtf file có vài chục ngàn dòng. Mỗi dòng có 1 phần dữ liệu ta muốn lấy.
Thí dụ "Cái máy model XX-XXX-XXX được bán với giá USD XXXXX ngày bán dd/mm/yyyy. Giá trị giá tiền và số máy thay đổi từng ô. Tuy vậy ta biết được là Số model là chử thứ 4 trong dãy string. Còn giá tiền là chử thứ 10 và loại tiền là thứ 9. Trong trường hợp này muốn lấy hàng loạt số model máy và giá tiền thì cần
1/ Dùng hàm trên để tìm ra vị trí chồ trắng thứ 4, 9 & 10.
2/ Tìm khoảng cách từ chử 4 dến 5, từ 10 đến 11 (loại tiền thì lúc nào cũng có 3 chử.
3/ Rồi sau đó dùng hàm Mid trong VBA để lấy data.
Không rõ là ý bạn cần biết cách mở 1 txt file trong XL hay là save 1 file từ trong XL qua dạng txt.
Thôi thì trả lời luôn 2 cách nha.
Mở 1 txt file
Trong hộp thoại file open bạn cần vô hộp "File of type" dưới cùng & chọn All files *.* & OK. Sau đó XL sẽ mở cái Text import wizard để cho bạn chọn cách hiển thị text data trên XL bạn chọn 1 trong các option rồi bấm nút OK.
Save qua dạng text
Chọn Save As trong thanh menu rồi trong hộp Save as Type chọn Text rồi cho tên mới vào và bấm OK.
Chúc bạn thành công
Cảm ơn Lam_A0, mình đã tự nhận là không chuyên nghiệp vì mình chưa từng được học VBA (hoặc là cà VB) bao giờ, mà chỉ lên diễn đàn học hỏi rồi tự thực hành. Nhưng cái quan trọng là nó đã giúp được chính mình trong công việc thực tế mà mình đang làm rất nhiều, nó cũng giúp cho mình thực hiện các ý tưởng muốn làm.
Nhân đây, mình cũng mong muốn diễn đàn tăng cường trao đổi có tính chất bài bản hơn về VBA. Mình rất thích ý tưởng của KDK về topic này.
Cũng rất cảm ơn KDK.
Hàm Dao_Chuoi
Hàm đảo chuỗi "cực chuẩn"/-*+/
=Dao_Chuoi(" Năm —- Ngày —– Tháng ")
Kết quả là " Tháng —– Ngày —- Năm "
Option Explicit
Function DaoNguoc(StrC As String) As String
Dim J As Integer
For J = 1 To Len(StrC)
DaoNguoc = Mid(StrC, J, 1) & DaoNguoc
Next J
End Function
Topic này đóng rồi hả mọi người, em vào GPE giữa tháng 10, tập tành viết code, nay em viết được 1 hàm mới theo nhu cầu công việc.
Hy vọng giúp ích cho mọi người và cũng hy vọng nhận được sự chỉ bảo từ những người đi trước.
Em viết hàm TRANSPOSES(Dãy dữ liệu, số cột cần chia)
5858