Бывают случаи, когда писать числа полезно или даже обязательно. Например, вы можете записать «1234» как «одна тысяча двести тридцать четыре». Следующий макрос NumberToWords делает именно это. Он довольно длинный, но для того, чтобы собрать правильную строку, нужно много проверять. Фактически в наборе пять макросов; четыре, помимо NumberToWords, вызываются NumberToWords для фактического преобразования.

NumberToWords преобразует любое число от 0 до 999 999. Чтобы использовать его, просто выберите ячейку (или ячейки), содержимое которых вы хотите преобразовать, а затем запустите ее. Обратите внимание, что ячейки должны содержать целые числа, а не формулы, которые приводят к целым числам. Фактическое содержимое соответствующих ячеек изменяется с исходного числа на текстовое представление этого числа. Другими словами, это не изменение формата, а изменение значений этих ячеек.

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

ExcelTips — ваш источник экономичного обучения Microsoft Excel.

Этот совет (8351) относится к Microsoft Excel 2007, 2010 и 2013. Вы можете найти версию этого совета для старого интерфейса меню Excel здесь:

link: / excel-Converting_Numbers_Into_Words [Преобразование чисел в слова].