مواقعی وجود دارد که املای اعداد مفید یا حتی اجباری است. برای مثال، ممکن است بخواهید "1234" را به صورت "هزار و دویست و سی و چهار" بنویسید. ماکرو زیر، NumberToWords، این کار را انجام می دهد. نسبتا طولانی است، اما باید بررسی های زیادی انجام دهد تا رشته مناسب را کنار هم قرار دهد. در واقع پنج ماکرو در مجموعه وجود دارد. چهار مورد در کنار NumberToWords توسط NumberToWords فراخوانی می شوند تا تبدیل واقعی را انجام دهند.
NumberToWords هر عددی را بین 0 تا 999999 تبدیل می کند. برای استفاده از آن، کافی است سلول (یا سلول‌هایی) که محتوای آن را می‌خواهید تبدیل کنید انتخاب کنید، سپس آن را اجرا کنید. باید توجه داشته باشید که سلول ها باید حاوی مقادیر عدد کامل باشند، نه فرمول هایی که به مقادیر عدد کامل منجر می شوند. محتوای واقعی سلول‌های سازگار از شماره اصلی به نمایش متنی آن عدد تغییر می‌کند. به عبارت دیگر، این یک تغییر قالب نیست، بلکه یک تغییر مقدار برای آن سلول ها است.
Sub NumberToWords()
Dim rngSrc As Range
Dim lMax As Long
Dim lCtr As Long
Dim bNCFlag As Boolean
Dim sTitle As String, sMsg As String
Dim vCVal As Variant
Dim lNumber As Long, sWords As String
Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address)
lMax = rngSrc.Cells.Count
bNCFlag = False
For lCtr = 1 To lMax
vCVal = rngSrc.Cells(lCtr).Value
sWords = ""
If IsNumeric(vCVal) Then
If vCVal <> CLng(vCVal) Then
bNCFlag = True
Else
lNumber = CLng(vCVal)
Select Case lNumber
Case 0
sWords = "Zero"
Case 1 To 999999
sWords = SetThousands(lNumber)
Case Else
bNCFlag = True
End Select
End If
Else
bNCFlag = True
End If
If sWords > "" Then
rngSrc.Cells(lCtr) = sWords
End If
Next lCtr
If bNCFlag Then
sTitle = "lNumberToWords Macro"
sMsg = "Not all cells converted. May not be whole number or may be too large."
MsgBox sMsg, vbExclamation, sTitle
End If
End Sub
Private Function SetOnes(ByVal lNumber As Integer) As String
Dim OnesArray(9) As String
OnesArray(1) = "One"
OnesArray(2) = "Two"
OnesArray(3) = "Three"
OnesArray(4) = "Four"
OnesArray(5) = "Five"
OnesArray(6) = "Six"
OnesArray(7) = "Seven"
OnesArray(8) = "Eight"
OnesArray(9) = "Nine"
SetOnes = OnesArray(lNumber)
End Function
Private Function SetTens(ByVal lNumber As Integer) As String
Dim TensArray(9) As String
TensArray(1) = "Ten"
TensArray(2) = "Twenty"
TensArray(3) = "Thirty"
TensArray(4) = "Fourty"
TensArray(5) = "Fifty"
TensArray(6) = "Sixty"
TensArray(7) = "Seventy"
TensArray(8) = "Eighty"
TensArray(9) = "Ninety"
Dim TeensArray(9) As String
TeensArray(1) = "Eleven"
TeensArray(2) = "Twelve"
TeensArray(3) = "Thirteen"
TeensArray(4) = "Fourteen"
TeensArray(5) = "Fifteen"
TeensArray(6) = "Sixteen"
TeensArray(7) = "Seventeen"
TeensArray(8) = "Eighteen"
TeensArray(9) = "Nineteen"
Dim iTemp1 As Integer
Dim iTemp2 As Integer
Dim sTemp As String
iTemp1 = Int(lNumber / 10)
iTemp2 = lNumber Mod 10
sTemp = TensArray(iTemp1)
If (iTemp1 = 1 And iTemp2 > 0) Then
sTemp = TeensArray(iTemp2)
Else
If (iTemp1 > 1 And iTemp2 > 0) Then
sTemp = sTemp + " " + SetOnes(iTemp2)
End If
End If
SetTens = sTemp
End Function
Private Function SetHundreds(ByVal lNumber As Integer) As String
Dim iTemp1 As Integer
Dim iTemp2 As Integer
Dim sTemp As String
iTemp1 = Int(lNumber / 100)
iTemp2 = lNumber Mod 100
If iTemp1 > 0 Then sTemp = SetOnes(iTemp1) + " Hundred"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
If iTemp2 < 10 Then sTemp = sTemp + SetOnes(iTemp2)
If iTemp2 > 9 Then sTemp = sTemp + SetTens(iTemp2)
End If
SetHundreds = sTemp
End Function
Private Function SetThousands(ByVal lNumber As Long) As String
Dim iTemp1 As Integer
Dim iTemp2 As Integer
Dim sTemp As String
iTemp1 = Int(lNumber / 1000)
iTemp2 = lNumber Mod 1000
If iTemp1 > 0 Then sTemp = SetHundreds(iTemp1) + " Thousand"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
sTemp = sTemp + SetHundreds(iTemp2)
End If
SetThousands = sTemp
End Function
