返回列表 上一主題 發帖

excel 將數字轉英文大寫

softsadwind

帖子
129 
主題
3 
精華
0 
積分
178 
點名
0  
作業系統
XP 
軟體版本
2010 
閱讀權限
20 
性別
男 
註冊時間
2010-12-28 
最後登錄
2018-11-10 
1# 跳轉到 »
發表於 2014-5-26 10:40 | 顯示全部帖子
回復 1# seci
  1. Option Explicit
  2. 'Main Function
  3. Function SpellNumber(ByVal MyNumber)
  4. Dim Dollars, Cents, Temp
  5. Dim DecimalPlace, Count
  6. ReDim Place(9) As String
  7. Place(2) = " Thousand "
  8. Place(3) = " Million "
  9. Place(4) = " Billion "
  10. Place(5) = " Trillion "
  11. ' 代表數字的字串。
  12. MyNumber = Trim(Str(MyNumber))
  13. ' 如果值為無，則十進位 0 的位置。
  14. DecimalPlace = InStr(MyNumber, ".")
  15. ' 換算分然後將 MyNumber 的數字設為元。
  16. If DecimalPlace > 0 Then
  17. Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
  18.                   "00", 2))
  19. MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
  20. End If
  21. Count = 1
  22. Do While MyNumber <> ""
  23. Temp = GetHundreds(Right(MyNumber, 3))
  24. If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
  25. If Len(MyNumber) > 3 Then
  26. MyNumber = Left(MyNumber, Len(MyNumber) - 3)
  27. Else
  28. MyNumber = ""
  29. End If
  30. Count = Count + 1
  31. Loop
  32. Select Case Dollars
  33. Case ""
  34. Dollars = "No Dollars"
  35. Case "One"
  36. 'Dollars = "One Dollar"
  37. Dollars = "One"
  38. Case Else
  39. 'Dollars = Dollars & " Dollars"
  40. Dollars = Dollars
  41. End Select
  42. Select Case Cents
  43. Case ""
  44. Cents = " and No Cents"
  45. Case "One"
  46. Cents = " and One Cent"
  47. Case Else
  48. Cents = " and " & Cents & " Cents"
  49. End Select
  50. SpellNumber = Dollars & Cents
  51. End Function
  52.       
  53. ' 將數字 100-999 轉換為文字
  54. Function GetHundreds(ByVal MyNumber)
  55. Dim Result As String
  56. If Val(MyNumber) = 0 Then Exit Function
  57. MyNumber = Right("000" & MyNumber, 3)
  58. ' 換算百進位的。
  59. If Mid(MyNumber, 1, 1) <> "0" Then
  60. Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
  61. End If
  62. ' 換算十進位和一進位。
  63. If Mid(MyNumber, 2, 1) <> "0" Then
  64. Result = Result & GetTens(Mid(MyNumber, 2))
  65. Else
  66. Result = Result & GetDigit(Mid(MyNumber, 3))
  67. End If
  68. GetHundreds = Result
  69. End Function
  70.       
  71. ' 將數字 10 到 99 轉換為文字。
  72. Function GetTens(TensText)
  73. Dim Result As String
  74. Result = ""           ' Null out the temporary function value.
  75. If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
  76. Select Case Val(TensText)
  77. Case 10: Result = "Ten"
  78. Case 11: Result = "Eleven"
  79. Case 12: Result = "Twelve"
  80. Case 13: Result = "Thirteen"
  81. Case 14: Result = "Fourteen"
  82. Case 15: Result = "Fifteen"
  83. Case 16: Result = "Sixteen"
  84. Case 17: Result = "Seventeen"
  85. Case 18: Result = "Eighteen"
  86. Case 19: Result = "Nineteen"
  87. Case Else
  88. End Select
  89. Else                                 ' 如果值介於 20-99...
  90. Select Case Val(Left(TensText, 1))
  91. Case 2: Result = "Twenty "
  92. Case 3: Result = "Thirty "
  93. Case 4: Result = "Forty "
  94. Case 5: Result = "Fifty "
  95. Case 6: Result = "Sixty "
  96. Case 7: Result = "Seventy "
  97. Case 8: Result = "Eighty "
  98. Case 9: Result = "Ninety "
  99. Case Else
  100. End Select
  101. Result = Result & GetDigit _
  102. (Right(TensText, 1))  ' Retrieve ones place.
  103. End If
  104. GetTens = Result
  105. End Function
  106.      
  107. ' 將數字 1 到 9 轉換為文字。
  108. Function GetDigit(Digit)
  109. Select Case Val(Digit)
  110. Case 1: GetDigit = "One"
  111. Case 2: GetDigit = "Two"
  112. Case 3: GetDigit = "Three"
  113. Case 4: GetDigit = "Four"
  114. Case 5: GetDigit = "Five"
  115. Case 6: GetDigit = "Six"
  116. Case 7: GetDigit = "Seven"
  117. Case 8: GetDigit = "Eight"
  118. Case 9: GetDigit = "Nine"
  119. Case Else: GetDigit = ""
  120. End Select
  121. End Function
複製代碼
改掉兩個地方就好
Case "One"
'Dollars = "One Dollar" 原本的
Dollars = "One"
Case Else
'Dollars = Dollars & " Dollars" 原本的
Dollars = Dollars
50 字節以內
不支持自定義 Discuz! 代碼

TOP

        靜思自在 : 人的心地是一畦田，土地沒有播下好種子，也長不出好的果實。 -
返回列表 上一主題