Bị lỗi font chữ trong vba đổi số thành chữ

[thanhcute1996]

VBA bị sai chính tả: " Mười triệu " mà nó viết thiếu dấu huyền. " Mươi triệu " . Nhờ anh em diễn đàn giúp đỡ!

Public Function HIEU(BaoNhieu) ' doc so viet nam dong Unicode
If Val(BaoNhieu) = 0 Then
Ketqua = "Không " & ChrW(273) & ChrW(7891) & "ng"
Else
If Abs(BaoNhieu) > 1E+15 Then
Ketqua = "S" & ChrW(7889) & " quá l" & ChrW(7899) & "n"
Else
If BaoNhieu < 0 Then Ketqua = "Âm" & Space(1) Else Ketqua = Space(0)
SOTIEN = Format(Abs(BaoNhieu), "###############0.00")
SOTIEN = Right(Space(15) & SOTIEN, 18)
Hang = Array("None", "tr" & ChrW(259) & "m", "m" & ChrW(432) & ChrW(417) & "i", "gì " & ChrW(273) & "ó")
DonVi = Array("None", "ngàn t" & ChrW(7927) & "", "t" & ChrW(7927) & "", "tri" & ChrW(7879) & "u", "ngàn", "" & ChrW(273) & ChrW(7891) & "ng", " ")
Dem = Array("None", "m" & ChrW(7897) & "t", "hai", "ba", "b" & ChrW(7889) & "n", "n" & ChrW(259) & "m", "sáu", "b" & ChrW(7843) & "y", "tám", "chín")
For n = 1 To 6
Nhom = Mid(SOTIEN, n * 3 - 2, 3)
If Nhom <> Space(3) Then
Select Case Nhom
Case "000"
If n = 5 Then
Chu = ChrW(273) & ChrW(7891) & "ng" & Space(1)
Else
Chu = Space(0)
End If
Case ".00", ",00"
Chu = ""
Case Else
S1 = Left(Nhom, 1): S2 = Mid(Nhom, 2, 1): S3 = Right(Nhom, 1)
Chu = Space(0): Hang(3) = DonVi(n)
For K = 1 To 3
Dich = Space(0): S = Val(Mid(Nhom, K, 1))
If S > 0 Then
Dich = Dem(S) & Space(1) & Hang(K) & Space(1)
Else
If K = 1 And n > 1 And n < 6 And Val(Mid(SOTIEN, (n - 1) * 3 - 2, 3)) > 0 Then
Dich = "không" & Space(1) & Hang(K) & Space(1)
End If
End If
Select Case K
Case 2 And S = 1
Dich = "m" & ChrW(432) & ChrW(417) & "i" & Space(1)
Case 3 And S = 0 And Nhom <> Space(2) & "0"
Dich = Hang(K) & Space(1)
Case 3 And S = 5 And Val(S2) > 2
Dich = "l" & Mid(Dich, 2)
Case 2 And S = 0 And S3 <> "0"
If n > 1 And Val(Mid(SOTIEN, (n - 1) * 3 - 2, 3)) > 0 Or (Val(S1) > 0) Then
Dich = "l" & ChrW(7867) & "" & Space(1)
End If
End Select
Chu = Chu & Dich
Next K
End Select
ViTri = InStr(1, Chu, "m" & ChrW(432) & ChrW(7901) & "i m" & ChrW(7897) & "t")
If ViTri > 0 Then Mid(Chu, ViTri, 9) = "m" & ChrW(432) & ChrW(417) & "i m" & ChrW(7889) & "t"
Ketqua = Ketqua & Chu
End If
Next n
End If
End If
HIEU = UCase(Left(Ketqua, 1)) & Trim(Mid(Ketqua, 2))
End Function

View more random threads:

• Mọi người giúp em với
• Giúp tìm ngày cuối cùng liên hệ với khách hàng
• cách tạo 1 file excel có thể cập nhật 1 vài cột dữ liệu từ 1 file excel khác!
• mọi người giúp em khóa cell theo chỉ định
• Mọi người giúp em với ạ !
• Tạo điều kiện cho drop list trong data validation -xin trợ giúp
• Xin giúp đỡ chạy macro màn hình không bị giật
• Gặp lỗi trong page setup excel 2010
• Hỏi về kế toán Công ty nhập khẩu da và sản xuất buôn bán giày dép
• Em sắp thi excel rồi, giúp e giải mấy bài này vs :(

[mavanthang]

Có ai giúp em với!. e đang cần lắm

[grantevil]

Có ai giúp em với!. e đang cần lắm

Code này không được thì lấy code khác mà xài! Sửa tới sửa lui cho mất công!

[loctongbietthu]

Code này không được thì lấy code khác mà xài! Sửa tới sửa lui cho mất công!

Em tìm hết rồi a. thấy cái này VNI. e sửa 1 lần rồi. Mong a giúp e.

[boombut]

Em tìm hết rồi a. thấy cái này VNI. e sửa 1 lần rồi. Mong a giúp e.

Chẳng hạn là code này của bạn huuthang_bd:

Function DocSo(ByVal Number, Optional ByVal Font = 1) As String
  Dim MyArray
  Dim Str
  Str = Format(Abs(Number), "000000000000000000")
  Select Case Font
  Case 1
    MyArray = Array("không ", "m" & ChrW(7897) & "t ", "hai ", "ba ", "b" & ChrW(7889) & "n ", "n" & ChrW(259) & "m ", "sáu ", "b" & ChrW(7843) & "y ", "tám ", "chín ", "tri" & ChrW(7879) & "u, ", "ngàn, ", "t" & ChrW(7927) & ", ", "tri" & ChrW(7879) & "u, ", "ngàn, ", "", "tr" & ChrW(259) & "m ", "m" & ChrW(432) & ChrW(417) & "i ", "không " & "m" & ChrW(432) & ChrW(417) & "i" & " không ", "không " & "m" & ChrW(432) & ChrW(417) & "i", "l" & ChrW(7867), "m" & ChrW(432) & ChrW(417) & "i" & " không", "m" & ChrW(432) & ChrW(417) & "i", "m" & ChrW(432) & ChrW(417) & "i" & " n" & ChrW(259) & "m", "m" & ChrW(432) & ChrW(417) & "i" & " l" & ChrW(259) & "m", "m" & ChrW(7897) & "t " & "m" & ChrW(432) & ChrW(417) & "i", "m" & ChrW(432) & ChrW(7901) & "i", "m" & ChrW(432) & ChrW(417) & "i" & " m" & ChrW(7897) & "t", "m" & ChrW(432) & ChrW(417) & "i" & " m" & ChrW(7889) & "t", "Âm ")
  Case 2
    MyArray = Array("khoâng ", "moät ", "hai ", "ba ", "boán ", "naêm ", "saùu ", "baûy ", "taùm ", "chín ", "trieäu, ", "ngaøn, ", "tyû, ", "trieäu, ", "ngaøn, ", "", "traêm ", "möôi ", "khoâng möôi khoâng ", "khoâng möôi", "leû", "möôi khoâng", "möôi", "möôi naêm", "möôi laêm", "moät möôi", "möôøi", "möôi moät", "möôi moát", "AÂm ")
  Case 3
    MyArray = Array("kh«ng ", "mét ", "hai ", "ba ", "bèn ", "n¨m ", "s¸u ", "b¶y ", "t¸m ", "chÝn ", "triÖu, ", "ngµn, ", "tû, ", "triÖu, ", "ngµn, ", "", "tr¨m ", "m­¬i ", "kh«ng m­¬i kh«ng ", "kh«ng m­¬i", "lÎ", "m­¬i kh«ng", "m­¬i", "m­¬i n¨m", "m­¬i l¨m", "mét m­¬i", "m­êi", "m­¬i mét", "m­¬i mèt", "©m ")
  End Select
  If Str = "000000000000000000" Then
    DocSo = UCase(Left(MyArray(0), 1)) & Trim(Mid(MyArray(0), 2))
    Exit Function
  End If
  Dim i As Long
  For i = 1 To Len(Str)
    If Left(Str, i) <> 0 And Mid(Str, (Int((i + 2) / 3) - 1) * 3 + 1, 3) <> 0 Then
      DocSo = DocSo & MyArray(Mid(Str, i, 1)) & MyArray(-(9 + i / 3) * (i Mod 3 = 0) - (15 + i Mod 3) * (i Mod 3 <> 0))
    ElseIf i = 9 And Mid(Str, 7, 3) = 0 And Left(Str, 6) <> 0 Then
      DocSo = DocSo & MyArray(12)
    End If
  Next
  DocSo = Trim(Replace(Replace(Replace(Replace(Replace(Replace(DocSo, MyArray(18), MyArray(15)), MyArray(19), MyArray(20)), MyArray(21), MyArray(22)), MyArray(23), MyArray(24)), MyArray(25), MyArray(26)), MyArray(27), MyArray(28)))
  If Number < 0 Then
    DocSo = MyArray(29) & DocSo
  End If
  DocSo = Replace(Replace(UCase(Left(DocSo, 1)) & Mid(DocSo, 2) & "*", ",*", ""), "*", "")
End Function

Code dùng cho cả 3 bảng mã: Unicode, VNI Windows và TCVN3