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:
Bị lỗi ndu à, nhưng sửa câu:
If IsMissing(ColIndex) Then ColIndex = Application.ThisCell.Column
thành:
If IsMissing(ColIndex) Then ColIndex = ActiveCell.Column
thì hết lỗi!
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:
PHP:
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...
 

File đính kèm

Upvote 0
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:
PHP:
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...
Ui chết rồi, mình cứ nghĩ là viết hàm để chạy trong VBA!!!

Vay ndu sử dụng hàm của ndu trong VBA thử xem
 
Lần chỉnh sửa cuối:
Upvote 0
Các Thầy có thể ráp 2 cái này thành 1 được không ạ?

Hàm 1:
PHP:
Function ColLetter(ByVal Cel As Range) As String
  ColLetter = Replace(Cells(1, Cel.Column).Address(0, 0), 1, "")
End Function
Hàm 2:
PHP:
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

Với Hàm 1, lấy địa chỉ ô của bất kỳ cột nào sẽ ra tên cột đó, tuy nhiên với cấu trúc như vầy thì lỗi: =ColLetter()

Với Hàm 2, thêm tham số thì ra số cột, kể cả =CotABC() cũng ra kết quả cột hiện hành, tuy nhiên với cấu trúc này thì lỗi: =CotABC(A1)

Nếu các Thầy ráp lại được, có thể sẽ là một hàm tổng quát hơn!
 
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])
 

File đính kèm

Upvote 0
Các Thầy có thể ráp 2 cái này thành 1 được không ạ?

Hàm 1:
PHP:
Function ColLetter(ByVal Cel As Range) As String
  ColLetter = Replace(Cells(1, Cel.Column).Address(0, 0), 1, "")
End Function
Hàm 2:
PHP:
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

Với Hàm 1, lấy địa chỉ ô của bất kỳ cột nào sẽ ra tên cột đó, tuy nhiên với cấu trúc như vầy thì lỗi: =ColLetter()

Với Hàm 2, thêm tham số thì ra số cột, kể cả =CotABC() cũng ra kết quả cột hiện hành, tuy nhiên với cấu trúc này thì lỗi: =CotABC(A1)

Nếu các Thầy ráp lại được, có thể sẽ là một hàm tổng quát hơn!
Em nghĩ không nên ráp lại.
Giả sử sau khi ráp lại ta có hàm CotABC() có chức năng là chức năng của hai hàm trên. Khi đó nếu A1 có giá trị là 2, ta dùng công thức sau thì kết quả sẽ là A hay là B?
Mã:
CotABC(A1)
 
Upvote 0
Các Thầy có thể ráp 2 cái này thành 1 được không ạ?

Hàm 1:
PHP:
Function ColLetter(ByVal Cel As Range) As String
  ColLetter = Replace(Cells(1, Cel.Column).Address(0, 0), 1, "")
End Function
Hàm 2:
PHP:
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

Với Hàm 1, lấy địa chỉ ô của bất kỳ cột nào sẽ ra tên cột đó, tuy nhiên với cấu trúc như vầy thì lỗi: =ColLetter()

Với Hàm 2, thêm tham số thì ra số cột, kể cả =CotABC() cũng ra kết quả cột hiện hành, tuy nhiên với cấu trúc này thì lỗi: =CotABC(A1)

Nếu các Thầy ráp lại được, có thể sẽ là một hàm tổng quát hơn!
Thí nghiệm vầy xem
PHP:
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
Em nghĩ không nên ráp lại.
Giả sử sau khi ráp lại ta có hàm CotABC() có chức năng là chức năng của hai hàm trên. Khi đó nếu A1 có giá trị là 2, ta dùng công thức sau thì kết quả sẽ là A hay là B?
Mã:
CotABC(A1)
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
 
Lần chỉnh sửa cuối:
Upvote 0
Thí nghiệm vầy xem
PHP:
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

Vâng, em đã kiểm tra, hàm cho ra kết quả rất chính xác! Cả 4 trường hợp ( [=CotABC()] ; [=CotABC(A1)] ; [=CotABC(1)] ; [=CotABC(VALUE(A1))] )

Nhưng với giá trị vượt quá 256 cột (đối với X2003) thì tính sao nhỉ? Với hàm này cho ra kết quả trắng, ừ thì vậy thôi chứ sao?
 
Upvote 0
Vâng, em đã kiểm tra, hàm cho ra kết quả rất chính xác! Cả 4 trường hợp ( [=CotABC()] ; [=CotABC(A1)] ; [=CotABC(1)] ; [=CotABC(VALUE(A1))] )

Nhưng với giá trị vượt quá 256 cột (đối với X2003) thì tính sao nhỉ? Với hàm này cho ra kết quả trắng, ừ thì vậy thôi chứ sao?
Hàm này sẽ tạo ra một chuỗi theo nguyên tắc đặt tên cột của Excel nhưng không bị giới hạn. Nếu thích anh có thể đưa vào hàm của anh ndu để cải tiến theo mục tiêu của anh.
PHP:
Function TenCot(Col As Long) As String
Do While Col > 0
    TenCot = Chr(((Col - 1) Mod 26) + 65) & TenCot
    Col = Int((Col - 1) / 26)
Loop
End Function
 
Upvote 0
Chuyển chuỗi Unicode sang ngôn ngữ VBA

Đôi khi chúng ta cần một câu thông báo bằng tiếng Việt trong khi đang lập trình một thủ tục nào đó. Hàm này sẽ chuyển chuỗi tiếng Việt Unicode sang ngôn ngữ VBA. Khỏi phải ngồi dò và ráp từng ký tự:
PHP:
Function CodeStr(MyStr As String) As String
Dim Str As String, CStart As Integer, CCount As Integer, Status As Boolean
Str = "-7842-7843-7841-259-7855-7857-7859-7861-7863-7845-7847-7849-7851-7853-273-7867-7869-7865-7871-7873-7875-7877-7879-7881-297-7883-7887-7885-7889-7891-7893-7895-7897-417-7899-7901-7903-7905-7907-7911-361-7909-432-7913-7915-7917-7919-7921-7923-7927-7929-7925-7840-258-7854-7856-7858-7860-7862-7844-7846-7848-7850-7852-272-7866-7868-7864-7870-7872-7874-7876-7878-7880-296-7882-7886-7884-7888-7890-7892-7894-7896-416-7898-7900-7902-7904-7906-7910-360-7908-431-7912-7914-7916-7918-7920-7922-7926-7928-7924-10-"
For i = 1 To Len(MyStr)
If InStr(Str, "-" & AscW(Mid(MyStr, i, 1)) & "-") = 0 Then
    If Not Status Then
        CStart = i:        Status = True
    End If
    CCount = CCount + 1
Else
    If Status Then CodeStr = CodeStr & IIf(CodeStr = "", "", " & ") & """" & Mid(MyStr, CStart, CCount) & """"
    Status = False
    CCount = 0
    CodeStr = CodeStr & IIf(CodeStr = "", "", " & ") & "ChrW(" & AscW(Mid(MyStr, i, 1)) & ")"
End If
Next
If Status Then CodeStr = CodeStr & IIf(CodeStr = "", "", " & ") & """" & Mid(MyStr, CStart, CCount) & """"
End Function
Ví dụ bạn gõ công thức:
Mã:
=CodeStr("Giải Pháp Excel - Công cụ tuyệt vời của bạn")
Thì sẽ được kết quả:
Mã:
"Gi" & ChrW(7843) & "i Pháp Excel - Công c" & ChrW(7909) & " tuy" & ChrW(7879) & "t v" & ChrW(7901) & "i c" & ChrW(7911) & "a b" & ChrW(7841) & "n"
 
Upvote 0
Ví dụ bạn gõ công thức:
Mã:
=CodeStr("Giải Pháp Excel - Công cụ tuyệt vời của bạn")
Thì sẽ được kết quả:
Mã:
"Gi" & ChrW(7843) & "i Pháp Excel - Công c" & ChrW(7909) & " tuy" & ChrW(7879) & "t v" & ChrW(7901) & "i c" & ChrW(7911) & "a b" & ChrW(7841) & "n"
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?
 
Upvote 0
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?
Đúng rồi anh.
Ví dụ trong VBA anh muốn viết lệnh để nhập chuỗi "Giải Pháp Excel - Công cụ tuyệt vời của bạn" vào ô A1 thì nhập công thức này vào một ô trên Excel
Mã:
=CodeStr("Giải Pháp Excel - Công cụ tuyệt vời của bạn")
Nhập xong nhấn F9 rồi copy, dán vào code:
PHP:
[A1] = "Gi" & ChrW(7843) & "i Pháp Excel - Công c" & ChrW(7909) & " tuy" & ChrW(7879) & "t v" & ChrW(7901) & "i c" & ChrW(7911) & "a b" & ChrW(7841) & "n"
 
Upvote 0
Đúng rồi anh.
Ví dụ trong VBA anh muốn viết lệnh để nhập chuỗi "Giải Pháp Excel - Công cụ tuyệt vời của bạn" vào ô A1 thì nhập công thức này vào một ô trên Excel
Mã:
=CodeStr("Giải Pháp Excel - Công cụ tuyệt vời của bạn")
Nhập xong nhấn F9 rồi copy, dán vào code:
PHP:
[A1] = "Gi" & ChrW(7843) & "i Pháp Excel - Công c" & ChrW(7909) & " tuy" & ChrW(7879) & "t v" & ChrW(7901) & "i c" & ChrW(7911) & "a b" & ChrW(7841) & "n"
Vậy thì.. cực quá...
Tôi dùng hàm này:
PHP:
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ụ:
PHP:
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
PHP:
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
 
Lần chỉnh sửa cuối:
Upvote 0
Vậy thì.. cực quá...
Tôi dùng hàm này:
PHP:
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ụ:
PHP:
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
PHP:
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
Em là người có thói quen bỏ dấu cuối từ khi gõ tiếng Việt nên chắc không dùng được hàm của anh. Ví dụ chữ "Giải" em sẽ gõ là Giair
Với lại nếu dùng hàm của anh dưới dạng Add-in thì khi gửi file cho người khác phải copy luôn hàm này vào trong file.
 
Lần chỉnh sửa cuối:
Upvote 0
Em là người có thói quen bỏ dấu cuối từ khi gõ tiếng Việt nên chắc không dùng được hàm của anh. Ví dụ chữ "Giải" em sẽ gõ là Giair
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
Với lại nếu dùng hàm của anh dưới dạng Add-in thì khi gửi file cho người khác phải copy luôn hàm này vào trong file.
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
 
Upvote 0
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
Em nghĩ tổng quát hoá hàm này là một việc rất khó. Nếu gõ dấu tự do thì có rất nhiều trường hợp nên không thể áp dụng thuật toán cũ. Ngoài ra, có thể gặp một số trường hợp kết quả chuyễn đổi ngoài mong muốn do chuỗi đầu vào có các nhóm ký tự vô tình trùng với các ký tự tiếng Việt. Ví dụ như:
PHP:
Sub TestTelex()
  Dim Text As String
  Text = "Text = "Chuwowng trifnh duwj ddoasn keest quar xoor soos treen excel""
  Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "Telex") & """,2)")
End Sub
Kết quả là: Chương trình dự đoán kết quả xổ số trên ẽcel (Chương trình dự đoán kết quả xổ số trên excel)
Hoặc
PHP:
Sub TestVNI()
  Dim Text As String
  Text = "Ba5n chu7a nha65p gia1 tri5 cho y1"
  Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "VNI") & """,2)")
End Sub
Kết quả là: Bạn chưa nhập giá trị cho ý (Bạn chưa nhập giá trị cho y1)
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
Ý em là hàm này chỉ mang tính chất hỗ trợ, về nguyên tắc ta có thể bỏ nó ra khỏi chương trình nên em thấy nếu file nào cũng đưa nó vào là không cần thiết.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Khó viết hàm tổng quát cho trường hợp này lắm Thầy ndu và Hữu Thắng ơi, bởi gõ dấu tự do bị ràng buộc nhiều điều kiện. Mình thì gõ kiểu VNI và gõ dấu kiểu tự do. Ví dụ nhỏ là viết chữ VƯỜN thì gõ VUON72 có khi lại gõ VUON27 có bộ gõ lại bắt gõ 2 số 7 mới được ƯƠ có bộ gõ chỉ cần gõ 1 lần 7.
 
Upvote 0
Em nghĩ tổng quát hoá hàm này là một việc rất khó. Nếu gõ dấu tự do thì có rất nhiều trường hợp nên không thể áp dụng thuật toán cũ. Ngoài ra, có thể gặp một số trường hợp kết quả chuyễn đổi ngoài mong muốn do chuỗi đầu vào có các nhóm ký tự vô tình trùng với các ký tự tiếng Việt. Ví dụ như:
PHP:
Sub TestTelex()
  Dim Text As String
  Text = "Text = "Chuwowng trifnh duwj ddoasn keest quar xoor soos treen excel""
  Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "Telex") & """,2)")
End Sub
Kết quả là: Chương trình dự đoán kết quả xổ số trên ẽcel (Chương trình dự đoán kết quả xổ số trên excel)
Hoặc
PHP:
Sub TestVNI()
  Dim Text As String
  Text = "Ba5n chu7a nha65p gia1 tri5 cho y1"
  Application.ExecuteExcel4Macro ("ALERT(""" & UniConvert(Text, "VNI") & """,2)")
End Sub
Kết quả là: Bạn chưa nhập giá trị cho ý (Bạn chưa nhập giá trị cho y1)

Ý em là hàm này chỉ mang tính chất hỗ trợ, về nguyên tắc ta có thể bỏ nó ra khỏi chương trình nên em thấy nếu file nào cũng đưa nó vào là không cần thiết.
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:
PHP:
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
 
Lần chỉnh sửa cuối:
Upvote 0
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:
PHP:
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é.
PHP:
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
PHP:
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
PHP:
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
PHP:
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
PHP:
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
PHP:
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
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
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/...-combobox-validation-list&p=192283#post192283
 
Upvote 0
Hàm tạo dãy số ngẫu nhiên không trùng (anhtuan1066):

PHP:
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:

PHP:
=UniqueRandomNum(Số nhỏ, Số lớn, bao nhiêu số cần tạo)

Nguồn: http://www.giaiphapexcel.com/forum/...số-ngẫu-nhiên-không-trùng&p=184501#post184501
 
Upvote 0
Web KT

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

Back
Top Bottom