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
