Đánh giá phần I:
Thử tìm hiểu về phiên bản mới của ASAP Utilities Version 3.08, 15/10/2004.
Range::Find/ replace in all sheet
Nút Expand, khi lần đầu tiên form hiện ra thì nút này "hình như" không có tác dụng. Các bạn hãy đọc đọan mã dưới đây và tự phân tích xem sao:
Private Sub cmdExpand_Click()
Debug.Print Me.Top
Dim snFactor As Single
snFactor = 1.3325
Dim intDefFormHeight As Integer
Dim intDefListHeight As Integer
Dim intNewFormHeight As Integer
Dim intNewListHeight As Integer
intDefFormHeight = 297
intDefListHeight = 129
intNewFormHeight = 297 + (fnGetScreenWidth / snFactor / 5)
intNewListHeight = intNewFormHeight - 169
If Me.Height > intDefFormHeight Then
'??????????????????????????
Me.Height = intDefFormHeight
Me.lstFound.Height = intDefListHeight
cmdExpand.Caption = "Expand >>"
Else
Me.Height = intNewFormHeight
Me.lstFound.Height = intNewListHeight
cmdExpand.Caption = "<< Smaller"
End If
End Sub
Và sau đây là thủ tục tìm kiếm, cũng rất hay:
Sub sbFindReplace(strSearch As String, _
wsstart As Worksheet, _
strrngStartSearch As String, _
intLookIn As Integer, _
blnMatchCase, _
blnEntireCellsOnly, _
intSearchOrder As Integer)
If intLookIn = 0 Then
varLookIn = xlFormulas
Else
varLookIn = xlValues
End If
If blnEntireCellsOnly = True Then
varLookAt = xlWhole
Else
varLookAt = xlPart
End If
If intSearchOrder = 0 Then
varSearchOrder = xlByRows
Else
varSearchOrder = xlByColumns
End If
If strSearch = "" Then Exit Sub
i = 0
For Each ws In ActiveWorkbook.Worksheets
Set rng = ws.Cells.Find(What:=strSearch, _
After:=ws.Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=varLookAt, _
SearchOrder:=varSearchOrder, _
SearchDirection:=xlNext, _
MatchCase:=blnMatchCase)
If Not rng Is Nothing Then
firstAddress = rng.Address
Do
If Not rng Is Nothing Then
lstFound.AddItem ws.Name
lstFound.Column(1, lstFound.ListCount - 1) = rng.Address
lstFound.Column(2, lstFound.ListCount - 1) = rng.Value
i = i + 1
End If
Set rng = ws.Cells.FindNext(rng)
Loop Until rng.Address = firstAddress
End If
Next ws
Me.lblItemsFound.Caption = i
End Sub
'''''''''''''''''''''
Sub sbFindReplace2()
Dim ws As Worksheet
Dim rng As Range
Dim strSearch As String
Dim ans As Variant
Dim firstAddress As String
strSearch = InputBox("Find what")
If strSearch = "" Then Exit Sub
For Each ws In ActiveWorkbook.Worksheets
Set rng = ws.Cells.Find(What:=strSearch, _
After:=ws.Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
firstAddress = rng.Address
Do
If Not rng Is Nothing Then
Application.GoTo rng, True
ans = MsgBox("Find Next?", _
vbYesNo + vbDefaultButton1)
If ans = vbNo Then Exit Sub
End If
Set rng = ws.Cells.FindNext(rng)
Loop Until rng.Address = firstAddress
End If
Next ws
End Sub
'''''''''''''''''''''''''''
Sub sbReplace(blnReplaceAll As Boolean)
If blnReplaceAll = False And lstFound.ListIndex = -1 Then
MsgBox "Select an entry to replace.", vbExclamation, AT
Me.lstFound.SetFocus
Exit Sub
End If
strSearch = Me.txtSearch.Text
strReplace = Me.txtReplace.Text
If Me.comLookIn.ListIndex = 0 Then
varLookIn = xlFormulas
Else
varLookIn = xlValues
End If
If Me.chkEntireCellsOnly = True Then
varLookAt = xlWhole
Else
varLookAt = xlPart
End If
If Me.comSearch.ListIndex = 0 Then
varSearchOrder = xlByRows
Else
varSearchOrder = xlByColumns
End If
Application.ScreenUpdating = False
If blnReplaceAll = False Then
Sheets(lstFound.List(lstFound.ListIndex, 0)).Select
Range(lstFound.List(lstFound.ListIndex, 1)).Select
ActiveCell.Replace strSearch, strReplace, varLookAt,varSearchOrder,
Me.chkMatchCase
lstFound.Column(3, lstFound.ListIndex) = "-> " & ActiveCell.Value
If lstFound.ListIndex < lstFound.ListCount - 1 Then lstFound.ListIndex = lstFound.ListIndex + 1
Else
For i = 0 To Me.lblItemsFound.Caption - 1
Sheets(lstFound.List(i, 0)).Select
Range(lstFound.List(i, 1)).Select
ActiveCell.Replace strSearch, strReplace, varLookAt, _
varSearchOrder,Me.chkMatchCase
lstFound.Column(3, i) = "-> " & ActiveCell.Value
Next i
End If
' Nham tang toc do chuong trinh
Application.ScreenUpdating = True
End Sub
Number:: Number to words
Có thể nói đây là hàm chuyển số thành chữ. Hàm chuyển số thành chữ ở các thứ tiếng: Anh, Đức, Hà Lan.
Sau đây là module modSpellNumberFuntions của tác giả:
Option Explicit
Sub Test()
ActiveCell.Offset(1, 1).Value = fnSpellNumbersEN(ActiveCell.Value, False, "euro", "euros", "comma", "cent", "cents")
ActiveCell.Offset(2, 1).Value = fnSpellNumbersEN(ActiveCell.Value, False, "euro", "euros", "point", "cent", "cents")
ActiveCell.Offset(8, 1).Value = fnSpellNumbersDE(ActiveCell.Value, True, "DM", "DM", "komma", "pfennig", "pfennige")
ActiveCell.Offset(9, 1).Value = fnSpellNumbersDE(ActiveCell.Value, True, "euro", "euros", "komma", "cent", "cents")
ActiveCell.Offset(10, 1).Value = fnSpellNumbersDE(ActiveCell.Value, False, "euro", "euros", "komma", "cent", "cents")
ActiveCell.Offset(11, 1).Value = fnSpellNumbersDE(ActiveCell.Value, False, "euro", "euros", "point", "cent", "cents")
ActiveCell.Offset(18, 1).Value = fnSpellNumbersNL(ActiveCell.Value, True, "DM", "DM", "komma", "pfennig", "pfennige")
ActiveCell.Offset(19, 1).Value = fnSpellNumbersNL(ActiveCell.Value, True, "euro", "euros", "komma", "cent", "cents")
ActiveCell.Offset(20, 1).Value = fnSpellNumbersNL(ActiveCell.Value, False, "euro", "euros", "komma", "cent", "cents")
ActiveCell.Offset(21, 1).Value = fnSpellNumbersNL(ActiveCell.Value, False, "euro", "euro", "komma", "cent", "cent")
End Sub
Function fnSpellNumbersEN( _
ByVal MyNumber, _
blnCurrency As Boolean, _
Optional strSingular As String, _
Optional strPlural As String, _
Optional strComma As String, _
Optional strCentSingular As String, _
Optional strCentPlural As String _
)
Dim Dollars, Cents, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "
MyNumber = Trim(Str(MyNumber))
DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
Cents = fnGetTensEN(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = fnGetHundredsEN(Right(MyNumber, 3))
If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Dollars
Case ""
If blnCurrency Then Dollars = "No " & strPlural
Case "One"
If blnCurrency Then
Dollars = "One " & strPlural
Else
Dollars = "One"
End If
Case Else
If blnCurrency Then
Dollars = Dollars & " " & strPlural
Else
Dollars = Dollars
End If
End Select
Select Case Cents
Case ""
If blnCurrency Then Cents = " and No " & strCentPlural
Case "One"
If blnCurrency Then
Cents = " and One " & strCentSingular
Else
Cents = " " & strComma & " zero One"
End If
Case Else
If blnCurrency Then
Cents = " and " & Cents & " " & strCentPlural
Else
If fnSmallerAsTenEN(Cents) Then
Cents = " " & strComma & " zero " & Cents
Else
Cents = " " & strComma & " " & Cents
End If
End If
End Select
fnSpellNumbersEN = Dollars & Cents
End Function
Function fnGetHundredsEN(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
If Mid(MyNumber, 1, 1) <> "0" Then
Result = fnGetDigitEN(Mid(MyNumber, 1, 1)) & " Hundred "
End If
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & fnGetTensEN(Mid(MyNumber, 2))
Else
Result = Result & fnGetDigitEN(Mid(MyNumber, 3))
End If
fnGetHundredsEN = Result
End Function
Function fnGetTensEN(TensText)
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
Case Else
End Select
Result = Result & fnGetDigitEN _
(Right(TensText, 1))
End If
fnGetTensEN = Result
End Function
Function fnGetDigitEN(Digit)
Select Case Val(Digit)
Case 1: fnGetDigitEN = "One"
Case 2: fnGetDigitEN = "Two"
Case 3: fnGetDigitEN = "Three"
Case 4: fnGetDigitEN = "Four"
Case 5: fnGetDigitEN = "Five"
Case 6: fnGetDigitEN = "Six"
Case 7: fnGetDigitEN = "Seven"
Case 8: fnGetDigitEN = "Eight"
Case 9: fnGetDigitEN = "Nine"
Case Else: fnGetDigitEN = ""
End Select
End Function