Mã hóa giúp tên sách

[diennguyen59]

Dùng cái này giải quyết chắc được ~ 90% [/code]

Em thử code của bác rồi, thấy cũng hay lắm đúng là đã giải quyết được ~ 90% rồi. Bác sửa giúp em chữ "Q" --> "QU" được không ạ?
Nếu có thể bác giúp em những từ đặc biệt này: gim, gin , ginh, gip, git lấy kí hiệu từ GI301 đến GI314.
Gim = GI + im --> GI301
An = A + an --> A105 Ân = Â + ân --> 121
Uyên = U + uyên --> U527 Yên = Y + yên --> Y603, v.v...
Cảm ơn bác nhiều!

[dudung94]

Em thử code của bác rồi, thấy cũng hay lắm đúng là đã giải quyết được ~ 90% rồi. Bác sửa giúp em chữ "Q" --> "QU" được không ạ?
Nếu có thể bác giúp em những từ đặc biệt này: gim, gin , ginh, gip, git lấy kí hiệu từ GI301 đến GI314.
Cảm ơn bác nhiều!

Bạn cần có 02 bảng:
1. Phụ âm--->Mã
2. Vần --->Mã

Bảng 2 đã có, bảng 1 bạn thiết kế nhé.

[longcheng]

Gửi lại bác file excel bác giúp đỡ nhé!

[appsmart]

Em thử code của bác rồi, thấy cũng hay lắm đúng là đã giải quyết được ~ 90% rồi. Bác sửa giúp em chữ "Q" --> "QU" được không ạ?
Nếu có thể bác giúp em những từ đặc biệt này: gim, gin , ginh, gip, git lấy kí hiệu từ GI301 đến GI314.
Gim = GI + im --> GI301
An = A + an --> A105 Ân = Â + ân --> 121
Uyên = U + uyên --> U527 Yên = Y + yên --> Y603, v.v...
Cảm ơn bác nhiều!

Kiểm tra file đính kèm xem sao.
Sách tiếng anh chắc không ổn

Public Sub Ma_Hoa_Ten_Sach()
Dim DL, MaVan, XoaDau, PhuAm, Tam, kq(), r As Long, rw As Long,c As Long, i

DL = Sheet2.Range("A2", Sheet2.Range("A65000").End(xlUp))
MaVan = Sheet1.Range("A1").CurrentRegion
XoaDau = Sheet1.Range("D1").CurrentRegion
PhuAm = Sheet1.Range("G1").CurrentRegion
ReDim kq(1 To UBound(DL), 5)

'Xoa dau, tach tu
For r = 1 To UBound(DL)
Tam = Split(LCase(DL(r, 1)) & " ", " ")
DL(r, 1) = Tam(0) & " " & Tam(1)

For c = 1 To Len(DL(r, 1))
For rw = 1 To UBound(XoaDau)
If Mid(DL(r, 1), c, 1) = XoaDau(rw, 1) Then
Mid(DL(r, 1), c, 1) = XoaDau(rw, 2)
End If
Next rw
Next c
Tam = Split(DL(r, 1), " ")

kq(r, 4) = Tam(0): kq(r, 5) = Tam(1)
Next r

'Tach PhuAm va Van. Nap ma so
With CreateObject("VBScript.RegExp")
For r = 1 To UBound(kq)

'Tách từ thứ 1
i = 0
For rw = 1 To UBound(PhuAm)
.Pattern = "^" & PhuAm(rw, 1)
If .test(kq(r, 4)) Then
If i < Len(.Execute(kq(r, 4))(0)) Then
i = Len(.Execute(kq(r, 4))(0))
End If
End If
Next rw

If i = 0 Then
kq(r, 1) = Left(kq(r, 4), 1): kq(r, 2) = kq(r, 4)
Else
kq(r, 1) = Left(kq(r, 4), i)
kq(r, 2) = Right(kq(r, 4), Len(kq(r, 4)) - i)
End If

'Tách từ thứ 2
i = 0
For rw = 1 To UBound(PhuAm)
.Pattern = "^" & PhuAm(rw, 1)
If .test(kq(r, 5)) Then
If i < Len(.Execute(kq(r, 5))(0)) Then
i = Len(.Execute(kq(r, 5))(0))
End If
End If
Next rw

If i = 0 Then
kq(r, 3) = Left(kq(r, 5), 1)
Else
kq(r, 3) = Left(kq(r, 5), i)
End If

'Nạp mã số vần
For rw = 1 To UBound(MaVan)
If kq(r, 2) = MaVan(rw, 1) Then kq(r, 2) = MaVan(rw, 2): Exit For
Next rw

'Kiểm tra lại mã số vần
'nếu không phải là số thì ghép thêm từ của phụ âm trước và nạp lại ( Chữ gi )
If IsNumeric(kq(r, 2)) = False Then
For rw = 1 To UBound(MaVan)
If Right(kq(r, 1), 1) & kq(r, 2) = MaVan(rw, 1) Then kq(r, 2) = MaVan(rw, 2): Exit For
Next rw
End If

kq(r, 0) = UCase(kq(r, 1) & kq(r, 2) & kq(r, 3))
Next r
End With

Sheet2.Range("B2").End(xlDown).ClearContents
Sheet2.Range("B2").Resize(UBound(DL), 1).Value = kq
End Sub