Tách các thành phần của tiếng (4 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
nghiank09

nghiank09

Thành viên hoạt động
Tham gia
1/3/12
Bài viết
143
Được thích
30
Xin chào mọi người!

Mình có vấn đề liên quan đến tách các thành phần của một tiếng (trong tiếng việt). Mình không biết dùng hàm gì để thực hiện, xin nhờ mọi người hỗ trợ ạ.

Untitled.png

Mình xin gửi file đính kèm:
 

File đính kèm

Chữ dây mà thanh bằng là thấy sai sai rồi, lẽ ra là "dấu" KHÔNG. Chị HUYỀN NGÃ NẶNG anh ơi. HỎI anh SẮC thuốc chị thời bớt KHÔNG. Còn bằng, trắc là niêm luật trong thơ ca. Thanh bằng gồm dấu HUYỀN và dấu KHÔNG. Thanh trắc gồm các dấu còn lại.
 
Maika8008 đã viết:
Chữ dây mà thanh bằng là thấy sai sai rồi, lẽ ra là "dấu" KHÔNG. Chị HUYỀN NGÃ NẶNG anh ơi. HỎI anh SẮC thuốc chị thời bớt KHÔNG. Còn bằng, trắc là niêm luật trong thơ ca. Thanh bằng gồm dấu HUYỀN và dấu KHÔNG. Thanh trắc gồm các dấu còn lại.
Nhấp chuột vào đây để mở rộng...
Câu đối: Sắc hỏi Huyền ngã nặng không - O e cu ca hát ít (o e q k h x).
 
Maika8008 đã viết:
... Thanh bằng gồm dấu HUYỀN và dấu KHÔNG. Thanh trắc gồm các dấu còn lại.
Nhấp chuột vào đây để mở rộng...
.
Nếu chỉ dùng để gieo vần làm thơ thì chỉ cần biết bằng trắc. Vần bằng chia làm phù bình thanh (không dấu) và trầm bình thanh (huyền).
Nếu phân tích "thanh" tiếng Việt (và tiếng Hán) thì thực ra có tất cả 4 thanh Bình Thượng Khứ Nhập, và 2 bậc Phù Trầm.
4 thanh hợp với 2 bậc cho ra tất cả 8 thanh. Tiếng Việt tuy chỉ có 6 dấu nhưng riêng dấu sắc và dấu nặng lại chia ra hai dòng, "Khứ" khi từ kết bình thường (vd tí, tín, tính) và "Nhập" khi từ kết bằng ch, p, t (vd. tích/tịch, tít/tịt, tiếp/tiệp).

Tôi không hiểu thớt muốn nói âm và thanh của mình là cái gì.
 
Lần chỉnh sửa cuối:
Thành thật xin lỗi các bạn, mình đã nhầm lẫn về thanh và dấu. Cho mình đính chính lại là mình muốn tách thành âm đầu, vần và dấu. Dấu ở đây gồm: sắc, huyền, hỏi, ngã, nặng và KHÔNG DẤU ạ. Mình cần tách tiếng ra các thành phần để hỗ trợ làm thơ và nghiên cứu về cách nói lái trong tiếng việt. Xin cám ơn các bạn.
 
Lần chỉnh sửa cuối:
nghiank09 đã viết:
Xin chào mọi người!

Mình có vấn đề liên quan đến tách các thành phần của một tiếng (trong tiếng việt). Mình không biết dùng hàm gì để thực hiện, xin nhờ mọi người hỗ trợ ạ.

View attachment 251918

Mình xin gửi file đính kèm:
Nhấp chuột vào đây để mở rộng...
Dùng hàm tự tạo
Mã: 
Dim KT$, Thanh$, aAmDau, aDau

Function TachVan(ByVal Text As String, ByVal iD As Long, ByVal Col As Long) As String
  Dim tmp$, j&, i&, Res1
 
  If Text = Empty Then Exit Function
  If KT = Empty Then Call CreateKyTu
  tmp = Split(Text, " ")(iD - 1)
  For j = UBound(aAmDau) To 0 Step -1
    If InStr(1, tmp, aAmDau(j), vbTextCompare) = 1 Then
      Res1 = aAmDau(j)
      If Col = 1 Then TachVan = Res1: Exit Function
      Exit For
    End If
  Next j
  If Res1 <> Empty Then tmp = Mid(tmp, Len(Res1) + 1, Len(tmp))
  For j = 1 To Len(tmp)
    i = InStr(1, Thanh, Mid(tmp, j, 1), vbTextCompare)
    If i > 0 Then
      If Col = 3 Then
        TachVan = aDau(((i - 1) Mod 5)): Exit Function
      ElseIf Col = 2 Then
        Mid(tmp, j, 1) = Mid(KT, i, 1)
        TachVan = tmp: Exit Function
      End If
    End If
  Next j
  If Col = 2 Then TachVan = tmp
End Function

Private Sub CreateKyTu()
  Dim aKT, aThanh, j&

  aDau = Array("s" & ChrW(7855) & "c", "huy" & ChrW(7873) & "n", "h" & ChrW(7887) & "i", "ngã", "n" & ChrW(7863) & "ng")
  aAmDau = Array("b", "c", "ch", "d", ChrW(273), "g", "gh", "gi", "h", "k", "kh", "l", "m", "n", "ng", "ngh", "nh", "ph", "qu", "r", "s", "t", "th", "tr", "v", "x")
  aKT = Array(97, 97, 97, 97, 97, 259, 259, 259, 259, 259, 226, 226, 226, 226, 226, 101, 101, 101, 101, 101, 234, 234, 234, 234, 234, 105, 105, 105, 105, 105, 111, 111, 111, 111, 111, 244, 244, 244, 244, 244, 417, 417, 417, 417, 417, 117, 117, 117, 117, 117, 432, 432, 432, 432, 432, 121, 121, 121, 121, 121)
  aThanh = Array(225, 224, 7843, 227, 7841, 7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925)
  For j = 0 To UBound(aKT)
    KT = KT & ChrW(aKT(j))
    Thanh = Thanh & ChrW(aThanh(j))
  Next j
End Sub
Xem cách dùng trong file
 

File đính kèm

HieuCD đã viết:
Dùng hàm tự tạo
Mã: 
Dim KT$, Thanh$, aAmDau, aDau

Function TachVan(ByVal Text As String, ByVal iD As Long, ByVal Col As Long) As String
  Dim tmp$, j&, i&, Res1

  If Text = Empty Then Exit Function
  If KT = Empty Then Call CreateKyTu
  tmp = Split(Text, " ")(iD - 1)
  For j = UBound(aAmDau) To 0 Step -1
    If InStr(1, tmp, aAmDau(j), vbTextCompare) = 1 Then
      Res1 = aAmDau(j)
      If Col = 1 Then TachVan = Res1: Exit Function
      Exit For
    End If
  Next j
  If Res1 <> Empty Then tmp = Mid(tmp, Len(Res1) + 1, Len(tmp))
  For j = 1 To Len(tmp)
    i = InStr(1, Thanh, Mid(tmp, j, 1), vbTextCompare)
    If i > 0 Then
      If Col = 3 Then
        TachVan = aDau(((i - 1) Mod 5)): Exit Function
      ElseIf Col = 2 Then
        Mid(tmp, j, 1) = Mid(KT, i, 1)
        TachVan = tmp: Exit Function
      End If
    End If
  Next j
  If Col = 2 Then TachVan = tmp
End Function

Private Sub CreateKyTu()
  Dim aKT, aThanh, j&

  aDau = Array("s" & ChrW(7855) & "c", "huy" & ChrW(7873) & "n", "h" & ChrW(7887) & "i", "ngã", "n" & ChrW(7863) & "ng")
  aAmDau = Array("b", "c", "ch", "d", ChrW(273), "g", "gh", "gi", "h", "k", "kh", "l", "m", "n", "ng", "ngh", "nh", "ph", "qu", "r", "s", "t", "th", "tr", "v", "x")
  aKT = Array(97, 97, 97, 97, 97, 259, 259, 259, 259, 259, 226, 226, 226, 226, 226, 101, 101, 101, 101, 101, 234, 234, 234, 234, 234, 105, 105, 105, 105, 105, 111, 111, 111, 111, 111, 244, 244, 244, 244, 244, 417, 417, 417, 417, 417, 117, 117, 117, 117, 117, 432, 432, 432, 432, 432, 121, 121, 121, 121, 121)
  aThanh = Array(225, 224, 7843, 227, 7841, 7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925)
  For j = 0 To UBound(aKT)
    KT = KT & ChrW(aKT(j))
    Thanh = Thanh & ChrW(aThanh(j))
  Next j
End Sub
Xem cách dùng trong file
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn đã hỗ trợ. Mình đã test và kết quả đúng. Bạn có thể cho mình hỏi thêm dòng code
aThanh = Array(225, 224, 7843, 227, 7841, 7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925)
là tập hợp các ký tự a,ă,â,u,ư,e,ê,o,ô,ơ,i,y kết hợp với 5 dấu: sắc, huyền, hỏi, ngã, nặng và không dấu phải không ạ :)
Bài đã được tự động gộp:

batman1 đã viết:
Nếu dữ liệu lấy từ nhiều nguồn thì phải chú ý. Vì code không phục vụ unicode tổ hợp.

View attachment 251982
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn rất nhiều
 
nghiank09 đã viết:
Cám ơn bạn đã hỗ trợ. Mình đã test và kết quả đúng. Bạn có thể cho mình hỏi thêm dòng code
aThanh = Array(225, 224, 7843, 227, 7841, 7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 7871, 7873, 7875, 7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925)
là tập hợp các ký tự a,ă,â,u,ư,e,ê,o,ô,ơ,i,y kết hợp với 5 dấu: sắc, huyền, hỏi, ngã, nặng và không dấu phải không ạ :)
Bài đã được tự động gộp:


Cám ơn bạn rất nhiều
Nhấp chuột vào đây để mở rộng...
aThanh là mảng các mã Ascii của á, à, ả, ã, ạ .....
 
nghiank09 đã viết:
Thành thật xin lỗi các bạn, mình đã nhầm lẫn về thanh và dấu. Cho mình đính chính lại là mình muốn tách thành âm đầu, vần và dấu. Dấu ở đây gồm: sắc, huyền, hỏi, ngã, nặng và KHÔNG DẤU ạ. Mình cần tách tiếng ra các thành phần để hỗ trợ làm thơ và nghiên cứu về cách nói lái trong tiếng việt. Xin cám ơn các bạn.
Nhấp chuột vào đây để mở rộng...
Tách như vậy mất công mà không làm gì được với làm thơ và nói lái đâu.

1. Làm thơ:
tuỳ theo thơ gì. Thơ lục bát thì chỉ cần trầm bình thanh và phù bình thanh. Thơ song thất lục bát thì nội dung quan trọng hơn hình thức. Tức là biết khi nào phải nhấn vần và hiệp vần
Nụ tầm xuân nở ra xanh biếc
Em (đã) có chồng anh tiếc lắm thay
biếc: màu xanh, hy vọng; vần với tiếc: mất mát. Một cặp đối chữ tuyệt hảo của văn chương bình dân Việt.
Thơ tám chữ thì cần nhịp chứ đâu cần thanh.

2. Nói lái:
việc phân thanh âm hoàn toàn vô bổ. Nói lái nằm trong thói quen, làm nhiều thì thạo. Hết.
Vả lại, cách phân tích của bạn chỉ có 6 thanh thì không đủ để nói lái. Nói lái liên quan đủ 8 thanh (như bài #4)
Ở đay ai cũng biết nghề trích từ và nói lái tôi đã đến mức tối thượng. Tôi có đủ thẩm quyền để phê phán điều này.
 

@nghiank09​

Bạn tham khảo Hàm UDF dưới đây để thực hiện cho mục đích của bạn

Gõ vào ô B2 công thức:
=S_Detach(A3:A10000)


Sao chép mã bên dưới vào một module
Lưu ý: mã chỉ hoạt động trên hệ điều hành window
JavaScript: 
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
Option Compare Text
#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Enum EnumMarkOfWord
  EMW_Outside = -1
  EMW_NoMark = 0
  EMW_graveAccent
  EMW_Acute
  EMW_Question
  EMW_tilde
  EMW_Dot
End Enum

Private Enum ArgsIndex
  AGI_Action = 0
  AGI_Formula
  AGI_caller
  AGI_Array
  AGI_Target
End Enum
#If Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
Private Args(), WorkIndex As Integer



Function S_Detach( _
  Optional ByVal Target As Range) As Variant
  On Error Resume Next
  Dim K As Integer, R, Formula$
  Set R = Application.Caller
  Formula = R(1, 1).Formula
  S_Detach = ChrW(194) & "m " & ChrW(273) & "" & ChrW(7847) & "u 1"
  K = UBound(Args)
  ReDim Preserve Args(1 To K + 1)
  Args(K + 1) = VBA.Array(0, Formula, R, 0, Target)
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Detach_callback)
  End If
End Function

Private Sub S_Detach_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  S_Detach_working
  On Error GoTo 0
End Sub

Private Sub S_Detach_working()
  On Error Resume Next
  Dim UA%, s$
  UA = UBound(Args)
  If UA > 0 Then
    WorkIndex = WorkIndex + 1
    Dim a: a = Args(WorkIndex)
    If a(AGI_Action) <> 0 Or a(AGI_caller).Formula <> a(AGI_Formula) Then
      GoTo n
    End If
    a(AGI_Action) = 1
    '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
    Dim R1 As Range
    Set R1 = a(AGI_Target)
    Dim R&, c%, IsUp As Boolean, vowel$
    Dim LR&, LC%, mc%, Text$, sp$(), Arr, total(), Title()
    LC = R1.Columns.Count

    LR = R1.Rows.Count
    LR = R1(LR + 4, 1).End(3).Row - R1.Row + 1
    If LR > 0 Then
      Arr = R1(1, 1).Resize(LR, 1).Value
      For R = 1 To LR
        Text = Application.WorksheetFunction.Trim(Arr(R, 1))
        If Len(Text) > 0 Then
          sp = Split(Text, " ")
          If UBound(sp) + 1 > mc Then
            mc = UBound(sp) + 1
            ReDim Preserve Title(1 To mc * 3 - 1)
            ReDim Preserve total(1 To LR, 1 To mc * 3)
            For c = 1 To UBound(sp) + 1
              If c > 1 Then
                Title((c - 1) * 3 + 0) = ChrW(194) & "m " & ChrW(273) & "" & ChrW(7847) & "u " & c
              End If
              Title((c - 1) * 3 + 1) = "V" & ChrW(7847) & "n " & c
              Title((c - 1) * 3 + 2) = "Thanh " & c
            Next
          End If
          For c = 0 To UBound(sp)
            total(R, (c) * 3 + 1) = consonant(sp(c), vowel)
            total(R, (c) * 3 + 2) = rhythmNoMark(vowel)
            total(R, (c) * 3 + 3) = MeanMarkOfVowel(vowel)
          Next
        End If
      Next R
   
      a(AGI_caller)(1, 2).Resize(1, mc * 3 - 1).Value = Title
      a(AGI_caller)(2, 1).Resize(LR, mc * 3).Value = total
   
      a(AGI_Action) = 2
    End If
 
    Set R1 = Nothing
    '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
n:
    If WorkIndex >= UA Then
      Erase Args: WorkIndex = 0
    Else
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Detach_callback)
    End If
  End If
  On Error GoTo 0
End Sub

Function MeanMarkOfVowel(ByVal vowel$) As String
  MeanMarkOfVowel = mark2Mean(markofvowel(vowel))
End Function
Function mark2Mean(mark&)
  Select Case mark
  Case EMW_graveAccent: mark2Mean = "Huy" & ChrW(7873) & "n"
  Case EMW_Acute: mark2Mean = "S" & ChrW(7855) & "c"
  Case EMW_Question: mark2Mean = "H" & ChrW(7887) & "i"
  Case EMW_tilde: mark2Mean = "Ng" & ChrW(227)
  Case EMW_Dot: mark2Mean = "N" & ChrW(7863) & "ng"
  Case EMW_NoMark: mark2Mean = "B" & ChrW(7857) & "ng"
  Case Else: mark2Mean = "Kh" & ChrW(225) & "c"
  End Select
End Function

Function markofvowel(ByVal vowel$) As EnumMarkOfWord
  Dim i%, t$, v&
  markofvowel = EMW_Outside
  For i = 1 To Len(vowel)
    t = Mid(vowel, i, 1)
    Select Case AscW(t)
    Case &H61, &H103, &HE2, &H65, &HEA, &H69, &H6F, &HF4, &H1A1, &H75, &H1B0, &H79, &H41, &H102, &HC2, &H45, &HCA, &H49, &H4F, &HD4, &H1A0, &H55, &H1AF, &H59
      markofvowel = EMW_NoMark
    Case &HE1, &H1EAF, &H1EA5, &HE9, &H1EBF, &HED, &HF3, &H1ED1, &H1EDB, &HFA, &H1EE9, &HFD, &HC1, &H1EAE, &H1EA4, &HC9, &H1EBE, &HCD, &HD3, &H1ED0, &H1EDA, &HDA, &H1EE8, &HDD
      markofvowel = EMW_Acute
    Case &HE0, &H1EB1, &H1EA7, &HE8, &H1EC1, &HEC, &HF2, &H1ED3, &H1EDD, &HF9, &H1EEB, &H1EF3, &HC0, &H1EB0, &H1EA6, &HC8, &H1EC0, &HCC, &HD2, &H1ED2, &H1EDC, &HD9, &H1EEA, &H1EF2
      markofvowel = EMW_graveAccent
    Case &H1EA3, &H1EB3, &H1EA9, &H1EBB, &H1EC3, &H1EC9, &H1ECF, &H1ED5, &H1EDF, &H1EE7, &H1EED, &H1EF7, &H1EA2, &H1EB2, &H1EA8, &H1EBA, &H1EC2, &H1EC8, &H1ECE, &H1ED4, &H1EDE, &H1EE6, &H1EEC, &H1EF6
      markofvowel = EMW_Question
    Case &HE3, &H1EB5, &H1EAB, &H1EBD, &H1EC5, &H129, &HF5, &H1ED7, &H1EE1, &H169, &H1EEF, &H1EF9, &HC3, &H1EB4, &H1EAA, &H1EBC, &H1EC4, &H128, &HD5, &H1ED6, &H1EE0, &H168, &H1EEE, &H1EF8
      markofvowel = EMW_tilde
    Case &H1EA1, &H1EB7, &H1EAD, &H1EB9, &H1EC7, &H1ECB, &H1ECD, &H1ED9, &H1EE3, &H1EE5, &H1EF1, &H1EF5, &H1EA0, &H1EB6, &H1EAC, &H1EB8, &H1EC6, &H1ECA, &H1ECC, &H1ED8, &H1EE2, &H1EE4, &H1EF0, &H1EF4
       markofvowel = EMW_Dot
    End Select
  Next
End Function

Function VowelNoMark(ByVal vowel) As String
  Dim v&, t&
  If IsNumeric(vowel) Then
    t = vowel
  Else
    t = AscW(vowel)
  End If
  Select Case t
  Case &H61, &HE1, &HE0, &H1EA3, &HE3, &H1EA1:          v = &H61
  Case &H103, &H1EAF, &H1EB1, &H1EB3, &H1EB5, &H1EB7:   v = &H103
  Case &HE2, &H1EA5, &H1EA7, &H1EA9, &H1EAB, &H1EAD:    v = &HE2
  Case &H65, &HE9, &HE8, &H1EBB, &H1EBD, &H1EB9:        v = &H65
  Case &HEA, &H1EBF, &H1EC1, &H1EC3, &H1EC5, &H1EC7:    v = &HEA
  Case &H69, &HED, &HEC, &H1EC9, &H129, &H1ECB:         v = &H69
  Case &H6F, &HF3, &HF2, &H1ECF, &HF5, &H1ECD:          v = &H6F
  Case &HF4, &H1ED1, &H1ED3, &H1ED5, &H1ED7, &H1ED9:    v = &HF4
  Case &H1A1, &H1EDB, &H1EDD, &H1EDF, &H1EE1, &H1EE3:   v = &H1A1
  Case &H75, &HFA, &HF9, &H1EE7, &H169, &H1EE5:         v = &H75
  Case &H1B0, &H1EE9, &H1EEB, &H1EED, &H1EEF, &H1EF1:   v = &H1B0
  Case &H79, &HFD, &H1EF3, &H1EF7, &H1EF9, &H1EF5:      v = &H79
  'UCase
  Case &H41, &HC1, &HC0, &H1EA2, &HC3, &H1EA0:          v = &H41
  Case &H102, &H1EAE, &H1EB0, &H1EB2, &H1EB4, &H1EB6:   v = &H102
  Case &HC2, &H1EA4, &H1EA6, &H1EA8, &H1EAA, &H1EAC:    v = &HC2
  Case &H45, &HC9, &HC8, &H1EBA, &H1EBC, &H1EB8:        v = &H45
  Case &HCA, &H1EBE, &H1EC0, &H1EC2, &H1EC4, &H1EC6:    v = &HCA
  Case &H49, &HCD, &HCC, &H1EC8, &H128, &H1ECA:         v = &H49
  Case &H4F, &HD3, &HD2, &H1ECE, &HD5, &H1ECC:          v = &H4F
  Case &HD4, &H1ED0, &H1ED2, &H1ED4, &H1ED6, &H1ED8:    v = &HD4
  Case &H1A0, &H1EDA, &H1EDC, &H1EDE, &H1EE0, &H1EE2:   v = &H1A0
  Case &H55, &HDA, &HD9, &H1EE6, &H168, &H1EE4:         v = &H55
  Case &H1AF, &H1EE8, &H1EEA, &H1EEC, &H1EEE, &H1EF0:   v = &H1AF
  Case &H59, &HDD, &H1EF2, &H1EF6, &H1EF8, &H1EF4:      v = &H59
  End Select
  If v > 0 Then
    VowelNoMark = ChrW(v)
  Else
    VowelNoMark = vowel
  End If
End Function
Function consonant(ByVal Word$, Optional ByRef vowel As String) As String
  On Error Resume Next
  Dim cons, c
  cons = Array("ngh", "gi", "ch", "gh", "kh", "ng", "nh", "ph", "qu", "th", "tr", "b", "c", "d", "h", "k", "l", "m", "n", "r", "s", "t", "v", "x", "p", "g", ChrW(272), ChrW(273))
  For Each c In cons
    If Left(Word, Len(c)) = c Then
      consonant = c
      vowel = Mid(Word, Len(c) + 1)
      Exit For
    End If
  Next
  If consonant = vbNullString Then
    vowel = Word
  End If
  On Error GoTo 0
End Function
Private Sub rhythmNoMark_test()
  Debug.Print rhythmNoMark("ti" & ChrW(7871) & "t")
End Sub
Function rhythmNoMark(ByVal Word As String) As String
  Dim i%, t$, v&, s$
  For i = 1 To Len(Word)
    t = Mid(Word, i, 1)
    Select Case AscW(t)
    Case &H61, &H103, &HE2, &H65, &HEA, &H69, &H6F, &HF4, &H1A1, &H75, &H1B0, &H79, &H41, &H102, &HC2, &H45, &HCA, &H49, &H4F, &HD4, &H1A0, &H55, &H1AF, &H59
        s = s & VowelNoMark(t)
    Case &HE1, &H1EAF, &H1EA5, &HE9, &H1EBF, &HED, &HF3, &H1ED1, &H1EDB, &HFA, &H1EE9, &HFD, &HC1, &H1EAE, &H1EA4, &HC9, &H1EBE, &HCD, &HD3, &H1ED0, &H1EDA, &HDA, &H1EE8, &HDD
      s = s & VowelNoMark(t)
    Case &HE0, &H1EB1, &H1EA7, &HE8, &H1EC1, &HEC, &HF2, &H1ED3, &H1EDD, &HF9, &H1EEB, &H1EF3, &HC0, &H1EB0, &H1EA6, &HC8, &H1EC0, &HCC, &HD2, &H1ED2, &H1EDC, &HD9, &H1EEA, &H1EF2
      s = s & VowelNoMark(t)
    Case &H1EA3, &H1EB3, &H1EA9, &H1EBB, &H1EC3, &H1EC9, &H1ECF, &H1ED5, &H1EDF, &H1EE7, &H1EED, &H1EF7, &H1EA2, &H1EB2, &H1EA8, &H1EBA, &H1EC2, &H1EC8, &H1ECE, &H1ED4, &H1EDE, &H1EE6, &H1EEC, &H1EF6
      s = s & VowelNoMark(t)
    Case &HE3, &H1EB5, &H1EAB, &H1EBD, &H1EC5, &H129, &HF5, &H1ED7, &H1EE1, &H169, &H1EEF, &H1EF9, &HC3, &H1EB4, &H1EAA, &H1EBC, &H1EC4, &H128, &HD5, &H1ED6, &H1EE0, &H168, &H1EEE, &H1EF8
      s = s & VowelNoMark(t)
    Case &H1EA1, &H1EB7, &H1EAD, &H1EB9, &H1EC7, &H1ECB, &H1ECD, &H1ED9, &H1EE3, &H1EE5, &H1EF1, &H1EF5, &H1EA0, &H1EB6, &H1EAC, &H1EB8, &H1EC6, &H1ECA, &H1ECC, &H1ED8, &H1EE2, &H1EE4, &H1EF0, &H1EF4
      s = s & VowelNoMark(t)
    Case Else
      s = s & t
    End Select
  Next
  rhythmNoMark = s
End Function

Private Sub sellconsonants_test()
  Debug.Print sellconsonants("c" & VBA.ChrW(7843) & "m")
End Sub
Function sellconsonants(ByVal Word$, Optional ByRef vowel As String) As String
  Call consonant(Word, Word)
  On Error Resume Next
  Dim c
  For Each c In Array("nh", "ng", "ch", "c", "m", "n", "t", "p")
    If Right(Word, Len(c)) = c Then
      sellconsonants = c
      vowel = Left(Word, Len(Word) - Len(c))
      Exit For
    End If
  Next
  On Error GoTo 0
End Function
 
Lần chỉnh sửa cuối:
HeSanbi đã viết:

@nghiank09​

Bạn tham khảo Hàm UDF dưới đây để thực hiện cho mục đích của bạn

Gõ vào ô B2 công thức:
=S_Detach(A3:A10000)


Sao chép mã bên dưới vào một module
Lưu ý: mã chỉ hoạt động trên hệ điều hành window
JavaScript: 
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
Option Compare Text
#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Enum EnumMarkOfWord
  EMW_Outside = -1
  EMW_NoMark = 0
  EMW_graveAccent
  EMW_Acute
  EMW_Question
  EMW_tilde
  EMW_Dot
End Enum

Private Enum ArgsIndex
  AGI_Action = 0
  AGI_Formula
  AGI_caller
  AGI_Array
  AGI_Target
End Enum
#If Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
Private Args(), WorkIndex As Integer



Function S_Detach( _
  Optional ByVal Target As Range) As Variant
  On Error Resume Next
  Dim K As Integer, R, Formula$
  Set R = Application.Caller
  Formula = R(1, 1).Formula
  S_Detach = ChrW(194) & "m " & ChrW(273) & "" & ChrW(7847) & "u 1"
  K = UBound(Args)
  ReDim Preserve Args(1 To K + 1)
  Args(K + 1) = VBA.Array(0, Formula, R, 0, Target)
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Detach_callback)
  End If
End Function

Private Sub S_Detach_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  S_Detach_working
  On Error GoTo 0
End Sub

Private Sub S_Detach_working()
  On Error Resume Next
  Dim UA%, s$
  UA = UBound(Args)
  If UA > 0 Then
    WorkIndex = WorkIndex + 1
    Dim a: a = Args(WorkIndex)
    If a(AGI_Action) <> 0 Or a(AGI_caller).Formula <> a(AGI_Formula) Then
      GoTo n
    End If
    a(AGI_Action) = 1
    '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
    Dim R1 As Range
    Set R1 = a(AGI_Target)
    Dim R&, c%, IsUp As Boolean, vowel$
    Dim LR&, LC%, mc%, Text$, sp$(), Arr, total(), Title()
    LC = R1.Columns.Count

    LR = R1.Rows.Count
    LR = R1(LR + 4, 1).End(3).Row - R1.Row + 1
    If LR > 0 Then
      Arr = R1(1, 1).Resize(LR, 1).Value
      For R = 1 To LR
        Text = Application.WorksheetFunction.Trim(Arr(R, 1))
        If Len(Text) > 0 Then
          sp = Split(Text, " ")
          If UBound(sp) + 1 > mc Then
            mc = UBound(sp) + 1
            ReDim Preserve Title(1 To mc * 3 - 1)
            ReDim Preserve total(1 To LR, 1 To mc * 3)
            For c = 1 To UBound(sp) + 1
              If c > 1 Then
                Title((c - 1) * 3 + 0) = ChrW(194) & "m " & ChrW(273) & "" & ChrW(7847) & "u " & c
              End If
              Title((c - 1) * 3 + 1) = "V" & ChrW(7847) & "n " & c
              Title((c - 1) * 3 + 2) = "Thanh " & c
            Next
          End If
          For c = 0 To UBound(sp)
            total(R, (c) * 3 + 1) = consonant(sp(c), vowel)
            total(R, (c) * 3 + 2) = rhythmNoMark(vowel)
            total(R, (c) * 3 + 3) = MeanMarkOfVowel(vowel)
          Next
        End If
      Next R
 
      a(AGI_caller)(1, 2).Resize(1, mc * 3 - 1).Value = Title
      a(AGI_caller)(2, 1).Resize(LR, mc * 3).Value = total
 
      a(AGI_Action) = 2
    End If

    Set R1 = Nothing
    '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
n:
    If WorkIndex >= UA Then
      Erase Args: WorkIndex = 0
    Else
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Detach_callback)
    End If
  End If
  On Error GoTo 0
End Sub

Function MeanMarkOfVowel(ByVal vowel$) As String
  MeanMarkOfVowel = mark2Mean(markofvowel(vowel))
End Function
Function mark2Mean(mark&)
  Select Case mark
  Case EMW_graveAccent: mark2Mean = "Huy" & ChrW(7873) & "n"
  Case EMW_Acute: mark2Mean = "S" & ChrW(7855) & "c"
  Case EMW_Question: mark2Mean = "H" & ChrW(7887) & "i"
  Case EMW_tilde: mark2Mean = "Ng" & ChrW(227)
  Case EMW_Dot: mark2Mean = "N" & ChrW(7863) & "ng"
  Case EMW_NoMark: mark2Mean = "B" & ChrW(7857) & "ng"
  Case Else: mark2Mean = "Kh" & ChrW(225) & "c"
  End Select
End Function

Function markofvowel(ByVal vowel$) As EnumMarkOfWord
  Dim i%, t$, v&
  markofvowel = EMW_Outside
  For i = 1 To Len(vowel)
    t = Mid(vowel, i, 1)
    Select Case AscW(t)
    Case &H61, &H103, &HE2, &H65, &HEA, &H69, &H6F, &HF4, &H1A1, &H75, &H1B0, &H79, &H41, &H102, &HC2, &H45, &HCA, &H49, &H4F, &HD4, &H1A0, &H55, &H1AF, &H59
      markofvowel = EMW_NoMark
    Case &HE1, &H1EAF, &H1EA5, &HE9, &H1EBF, &HED, &HF3, &H1ED1, &H1EDB, &HFA, &H1EE9, &HFD, &HC1, &H1EAE, &H1EA4, &HC9, &H1EBE, &HCD, &HD3, &H1ED0, &H1EDA, &HDA, &H1EE8, &HDD
      markofvowel = EMW_Acute
    Case &HE0, &H1EB1, &H1EA7, &HE8, &H1EC1, &HEC, &HF2, &H1ED3, &H1EDD, &HF9, &H1EEB, &H1EF3, &HC0, &H1EB0, &H1EA6, &HC8, &H1EC0, &HCC, &HD2, &H1ED2, &H1EDC, &HD9, &H1EEA, &H1EF2
      markofvowel = EMW_graveAccent
    Case &H1EA3, &H1EB3, &H1EA9, &H1EBB, &H1EC3, &H1EC9, &H1ECF, &H1ED5, &H1EDF, &H1EE7, &H1EED, &H1EF7, &H1EA2, &H1EB2, &H1EA8, &H1EBA, &H1EC2, &H1EC8, &H1ECE, &H1ED4, &H1EDE, &H1EE6, &H1EEC, &H1EF6
      markofvowel = EMW_Question
    Case &HE3, &H1EB5, &H1EAB, &H1EBD, &H1EC5, &H129, &HF5, &H1ED7, &H1EE1, &H169, &H1EEF, &H1EF9, &HC3, &H1EB4, &H1EAA, &H1EBC, &H1EC4, &H128, &HD5, &H1ED6, &H1EE0, &H168, &H1EEE, &H1EF8
      markofvowel = EMW_tilde
    Case &H1EA1, &H1EB7, &H1EAD, &H1EB9, &H1EC7, &H1ECB, &H1ECD, &H1ED9, &H1EE3, &H1EE5, &H1EF1, &H1EF5, &H1EA0, &H1EB6, &H1EAC, &H1EB8, &H1EC6, &H1ECA, &H1ECC, &H1ED8, &H1EE2, &H1EE4, &H1EF0, &H1EF4
       markofvowel = EMW_Dot
    End Select
  Next
End Function

Function VowelNoMark(ByVal vowel) As String
  Dim v&, t&
  If IsNumeric(vowel) Then
    t = vowel
  Else
    t = AscW(vowel)
  End If
  Select Case t
  Case &H61, &HE1, &HE0, &H1EA3, &HE3, &H1EA1:          v = &H61
  Case &H103, &H1EAF, &H1EB1, &H1EB3, &H1EB5, &H1EB7:   v = &H103
  Case &HE2, &H1EA5, &H1EA7, &H1EA9, &H1EAB, &H1EAD:    v = &HE2
  Case &H65, &HE9, &HE8, &H1EBB, &H1EBD, &H1EB9:        v = &H65
  Case &HEA, &H1EBF, &H1EC1, &H1EC3, &H1EC5, &H1EC7:    v = &HEA
  Case &H69, &HED, &HEC, &H1EC9, &H129, &H1ECB:         v = &H69
  Case &H6F, &HF3, &HF2, &H1ECF, &HF5, &H1ECD:          v = &H6F
  Case &HF4, &H1ED1, &H1ED3, &H1ED5, &H1ED7, &H1ED9:    v = &HF4
  Case &H1A1, &H1EDB, &H1EDD, &H1EDF, &H1EE1, &H1EE3:   v = &H1A1
  Case &H75, &HFA, &HF9, &H1EE7, &H169, &H1EE5:         v = &H75
  Case &H1B0, &H1EE9, &H1EEB, &H1EED, &H1EEF, &H1EF1:   v = &H1B0
  Case &H79, &HFD, &H1EF3, &H1EF7, &H1EF9, &H1EF5:      v = &H79
  'UCase
  Case &H41, &HC1, &HC0, &H1EA2, &HC3, &H1EA0:          v = &H41
  Case &H102, &H1EAE, &H1EB0, &H1EB2, &H1EB4, &H1EB6:   v = &H102
  Case &HC2, &H1EA4, &H1EA6, &H1EA8, &H1EAA, &H1EAC:    v = &HC2
  Case &H45, &HC9, &HC8, &H1EBA, &H1EBC, &H1EB8:        v = &H45
  Case &HCA, &H1EBE, &H1EC0, &H1EC2, &H1EC4, &H1EC6:    v = &HCA
  Case &H49, &HCD, &HCC, &H1EC8, &H128, &H1ECA:         v = &H49
  Case &H4F, &HD3, &HD2, &H1ECE, &HD5, &H1ECC:          v = &H4F
  Case &HD4, &H1ED0, &H1ED2, &H1ED4, &H1ED6, &H1ED8:    v = &HD4
  Case &H1A0, &H1EDA, &H1EDC, &H1EDE, &H1EE0, &H1EE2:   v = &H1A0
  Case &H55, &HDA, &HD9, &H1EE6, &H168, &H1EE4:         v = &H55
  Case &H1AF, &H1EE8, &H1EEA, &H1EEC, &H1EEE, &H1EF0:   v = &H1AF
  Case &H59, &HDD, &H1EF2, &H1EF6, &H1EF8, &H1EF4:      v = &H59
  End Select
  If v > 0 Then
    VowelNoMark = ChrW(v)
  Else
    VowelNoMark = vowel
  End If
End Function
Function consonant(ByVal Word$, Optional ByRef vowel As String) As String
  On Error Resume Next
  Dim cons, c
  cons = Array("ngh", "gi", "ch", "gh", "kh", "ng", "nh", "ph", "qu", "th", "tr", "b", "c", "d", "h", "k", "l", "m", "n", "r", "s", "t", "v", "x", "p", "g", ChrW(272), ChrW(273))
  For Each c In cons
    If Left(Word, Len(c)) = c Then
      consonant = c
      vowel = Mid(Word, Len(c) + 1)
      Exit For
    End If
  Next
  If consonant = vbNullString Then
    vowel = Word
  End If
  On Error GoTo 0
End Function
Private Sub rhythmNoMark_test()
  Debug.Print rhythmNoMark("ti" & ChrW(7871) & "t")
End Sub
Function rhythmNoMark(ByVal Word As String) As String
  Dim i%, t$, v&, s$
  For i = 1 To Len(Word)
    t = Mid(Word, i, 1)
    Select Case AscW(t)
    Case &H61, &H103, &HE2, &H65, &HEA, &H69, &H6F, &HF4, &H1A1, &H75, &H1B0, &H79, &H41, &H102, &HC2, &H45, &HCA, &H49, &H4F, &HD4, &H1A0, &H55, &H1AF, &H59
        s = s & VowelNoMark(t)
    Case &HE1, &H1EAF, &H1EA5, &HE9, &H1EBF, &HED, &HF3, &H1ED1, &H1EDB, &HFA, &H1EE9, &HFD, &HC1, &H1EAE, &H1EA4, &HC9, &H1EBE, &HCD, &HD3, &H1ED0, &H1EDA, &HDA, &H1EE8, &HDD
      s = s & VowelNoMark(t)
    Case &HE0, &H1EB1, &H1EA7, &HE8, &H1EC1, &HEC, &HF2, &H1ED3, &H1EDD, &HF9, &H1EEB, &H1EF3, &HC0, &H1EB0, &H1EA6, &HC8, &H1EC0, &HCC, &HD2, &H1ED2, &H1EDC, &HD9, &H1EEA, &H1EF2
      s = s & VowelNoMark(t)
    Case &H1EA3, &H1EB3, &H1EA9, &H1EBB, &H1EC3, &H1EC9, &H1ECF, &H1ED5, &H1EDF, &H1EE7, &H1EED, &H1EF7, &H1EA2, &H1EB2, &H1EA8, &H1EBA, &H1EC2, &H1EC8, &H1ECE, &H1ED4, &H1EDE, &H1EE6, &H1EEC, &H1EF6
      s = s & VowelNoMark(t)
    Case &HE3, &H1EB5, &H1EAB, &H1EBD, &H1EC5, &H129, &HF5, &H1ED7, &H1EE1, &H169, &H1EEF, &H1EF9, &HC3, &H1EB4, &H1EAA, &H1EBC, &H1EC4, &H128, &HD5, &H1ED6, &H1EE0, &H168, &H1EEE, &H1EF8
      s = s & VowelNoMark(t)
    Case &H1EA1, &H1EB7, &H1EAD, &H1EB9, &H1EC7, &H1ECB, &H1ECD, &H1ED9, &H1EE3, &H1EE5, &H1EF1, &H1EF5, &H1EA0, &H1EB6, &H1EAC, &H1EB8, &H1EC6, &H1ECA, &H1ECC, &H1ED8, &H1EE2, &H1EE4, &H1EF0, &H1EF4
      s = s & VowelNoMark(t)
    Case Else
      s = s & t
    End Select
  Next
  rhythmNoMark = s
End Function

Private Sub sellconsonants_test()
  Debug.Print sellconsonants("c" & VBA.ChrW(7843) & "m")
End Sub
Function sellconsonants(ByVal Word$, Optional ByRef vowel As String) As String
  Call consonant(Word, Word)
  On Error Resume Next
  Dim c
  For Each c In Array("nh", "ng", "ch", "c", "m", "n", "t", "p")
    If Right(Word, Len(c)) = c Then
      sellconsonants = c
      vowel = Left(Word, Len(Word) - Len(c))
      Exit For
    End If
  Next
  On Error GoTo 0
End Function
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn đã hỗ trợ :).
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt (2 người xem)
Trả lời
3
Đọc
86
clien172
C
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
G
Xin Code xóa Module.
Trả lời
8
Đọc
261
huhumalu
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
135
tle2003
T
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
22
Đọc
531
nguyendang95
N
S
Mở 2 cửa sổ riêng biệt (1 người xem)
2
Trả lời
30
Đọc
23K
sakuraluu
S
F
Nhập dấu . (chấm) ở bàn phím phụ không tự chuyển thành dấu , (phẩy) (1 người xem)
Trả lời
16
Đọc
57K
tubaodn21
tubaodn21
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
21
Đọc
1K
PhanTuHuong
PhanTuHuong
L
Lỗi font khi convert từ pdf
Trả lời
3
Đọc
136
lamvu0677
L
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
9
Đọc
5K
SonBDND
S
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (1 người xem)
    • Thích
Trả lời
0
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
1
Đọc
114
khkkh
K
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
788
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
222
Hoàng Tuấn 868
H
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
0
Đọc
141
nguyendang95
N
H
Nhờ anh/chị giúp đỡ em viết công thức trừ dữ liệu theo FiFo
Trả lời
1
Đọc
131
HieuCD
H
BNTT
LockXLS - Chương trình bảo vệ an toàn cho các file bảng tính Excel
    • Thích
4 5 6
Trả lời
118
Đọc
73K
YêuCN
Y
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
14
Đọc
219
thuytrangbp28
T
micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA
Trả lời
4
Đọc
708
thuytrangbp28
T
Emyeuexcel
  • Question Question
In tất cả các file trong cùng 1 thư mục
Trả lời
3
Đọc
228
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom