Nhờ chuyển họ tên thành mã rút gọn

Liên hệ QC
H

Hidden2562

Thành viên mới
Tham gia
18/3/20
Bài viết
22
Được thích
6
Chào mọi người
Hiện tại mình có dữ liệu như sau:
Nguyễn Văn A -> a.v.nguyen
Nguyễn Thị Minh Khai -> khai.tm.nguyen
có công thức nào chuyển đổi được như vậy không ạ?
 
Hidden2562 đã viết:
Chào mọi người
Hiện tại mình có dữ liệu như sau:
Nguyễn Văn A -> a.v.nguyen
Nguyễn Thị Minh Khai -> khai.tm.nguyen
có công thức nào chuyển đổi được như vậy không ạ?
Nhấp chuột vào đây để mở rộng...
Dùng hàm và công thức thông thường bài này thì có lẽ khó mà làm được.
Chắc phải cậy nhờ đến VBA thôi bạn ạ.
Bạn tham khảo ở bài viết sau: https://www.giaiphapexcel.com/diendan/threads/xin-code-tạo-mã-nhân-viên.74625/post-457201
 
vanthinh3101 đã viết:
Dùng hàm và công thức thông thường bài này thì có lẽ khó mà làm được.
Chắc phải cậy nhờ đến VBA thôi bạn ạ.
Bạn tham khảo ở bài viết sau: https://www.giaiphapexcel.com/diendan/threads/xin-code-tạo-mã-nhân-viên.74625/post-457201
Nhấp chuột vào đây để mở rộng...
Ý, mình nghĩ dùng 1 (vài) cột phụ có lẽ sẽ xử lý được á. Còn dùng hàm trực tiếp chuyển qua thì mình thua thiệt, hi.
phuongvq123 đã viết:
bạn dùng phiên bản bao nhiêu
Nhấp chuột vào đây để mở rộng...
Mình cũng muốn hỏi câu giống bạn. :D
 
Mình hơi tò mò & xin hỏi chủ bài đăng: Bạn mã hóa như vậy để dùng vô việc gì?
:D }}}}}
 
Lần chỉnh sửa cuối:
Trong Unikey cũng có phần bỏ dấu tiếng Việt đấy, bỏ hết dấu đi rồi làm tiếp sau
 
Hidden2562 đã viết:
Chào mọi người
Hiện tại mình có dữ liệu như sau:
Nguyễn Văn A -> a.v.nguyen
Nguyễn Thị Minh Khai -> khai.tm.nguyen
có công thức nào chuyển đổi được như vậy không ạ?
Nhấp chuột vào đây để mở rộng...
Bạn gửi file có đại 100 người họ tên đầy đủ đi. Mình làm thử xem !
 
Hidden2562 đã viết:
Chào mọi người
Hiện tại mình có dữ liệu như sau:
Nguyễn Văn A -> a.v.nguyen
Nguyễn Thị Minh Khai -> khai.tm.nguyen
có công thức nào chuyển đổi được như vậy không ạ?
Nhấp chuột vào đây để mở rộng...
Bạn tham khảo file đính kèm xem đúng yêu cầu không?
code cho hàm tự tạo như sau:

Mã: 
Function Rutgon(Str As String) As String
Dim i As Long, k As Long
Dim a As String, b As String
Dim Arr()

For i = 1 To Len(Str)
    If Mid(Str, i, 1) = " " Then
        k = k + 1
        If k = 1 Then a = Left(Str, i - 1)
        b = Right(Str, Len(Str) - i)
        ReDim Preserve Arr(1 To k)
        Arr(k) = Mid(Str, i + 1, 1)
    End If
Next
If k > 0 Then
    If k > 1 Then
        ReDim Preserve Arr(1 To k - 1)
        Rutgon = b & "." & Join(Arr, ".") & "." & a
    Else
        Rutgon = b & "." & a
    End If
End If
End Function
 

File đính kèm

  • test.xlsb
    14 KB · Đọc: 4
Ba Tê đã viết:
Yêu cầu sau khi ghép không có dấu tiếng Việt, không còn chữ Hoa.
Nhấp chuột vào đây để mở rộng...
Em quên không đọc kỹ đề bào,
Thôi đã chót rồi dù bận cũng phải cố làm cho xong bằng cách thêm hàm cùi bắp "bodau" cho chuỗi vừa rút gọn được dưới đây ạ:
Mã: 
Function Rutgon(Str As String) As String
Dim i As Long, k As Long
Dim a As String, b As String
Dim Arr()

For i = 1 To Len(Str)
    If Mid(Str, i, 1) = " " Then
        k = k + 1
        If k = 1 Then a = Left(Str, i - 1)
        b = Right(Str, Len(Str) - i)
        ReDim Preserve Arr(1 To k)
        Arr(k) = Mid(Str, i + 1, 1)
    End If
Next
If k > 0 Then
    If k > 1 Then
        ReDim Preserve Arr(1 To k - 1)
        Rutgon = bodau(b & "." & Join(Arr, ".") & "." & a)
    Else
        Rutgon = bodau(b & "." & a)
    End If
End If
End Function
Function bodau(chuoi As String) As String
Dim i As Long, Arr(1 To 26, 1 To 2)
Dim j As Long, Str As String

For i = 1 To 26
    Arr(i, 1) = ChrW(i + 96)
    Arr(i, 2) = ChrW(i + 96)
Next
For j = 1 To Len(chuoi)
    If Mid(chuoi, j, 1) = "." Then
        Str = Str & Mid(chuoi, j, 1)
    Else
        Str = Str & WorksheetFunction.VLookup(Mid(chuoi, j, 1), Arr, 2, 1)
    End If
Next
bodau = Str
End Function
 

File đính kèm

  • test.xlsb
    86 KB · Đọc: 3
nguyenthuy13388 đã viết:
Em quên không đọc kỹ đề bào,
Thôi đã chót rồi dù bận cũng phải cố làm cho xong bằng cách thêm hàm cùi bắp "bodau" cho chuỗi vừa rút gọn được dưới đây ạ:
Mã: 
Function Rutgon(Str As String) As String
Dim i As Long, k As Long
Dim a As String, b As String
Dim Arr()

For i = 1 To Len(Str)
    If Mid(Str, i, 1) = " " Then
        k = k + 1
        If k = 1 Then a = Left(Str, i - 1)
        b = Right(Str, Len(Str) - i)
        ReDim Preserve Arr(1 To k)
        Arr(k) = Mid(Str, i + 1, 1)
    End If
Next
If k > 0 Then
    If k > 1 Then
        ReDim Preserve Arr(1 To k - 1)
        Rutgon = bodau(b & "." & Join(Arr, ".") & "." & a)
    Else
        Rutgon = bodau(b & "." & a)
    End If
End If
End Function
Function bodau(chuoi As String) As String
Dim i As Long, Arr(1 To 26, 1 To 2)
Dim j As Long, Str As String

For i = 1 To 26
    Arr(i, 1) = ChrW(i + 96)
    Arr(i, 2) = ChrW(i + 96)
Next
For j = 1 To Len(chuoi)
    If Mid(chuoi, j, 1) = "." Then
        Str = Str & Mid(chuoi, j, 1)
    Else
        Str = Str & WorksheetFunction.VLookup(Mid(chuoi, j, 1), Arr, 2, 1)
    End If
Next
bodau = Str
End Function
Nhấp chuột vào đây để mở rộng...
Còn chút xiu nữa là chạy ngon r bác ơi

VD:
Nguyễn Thị Minh Khai -> khai.tm.nguyen ("tm" không có dấu . ở giữa)

còn của bác là "khai.t.m.nguyen"
 
Hidden2562 đã viết:
Còn chút xiu nữa là chạy ngon r bác ơi

VD:
Nguyễn Thị Minh Khai -> khai.tm.nguyen ("tm" không có dấu . ở giữa)

còn của bác là "khai.t.m.nguyen"
Nhấp chuột vào đây để mở rộng...
đơn giản sử dấu "." thành "" của hàm join thôi mà:

Mã: 
Function Rutgon(Str As String) As String
Dim i As Long, k As Long
Dim a As String, b As String
Dim Arr()

For i = 1 To Len(Str)
    If Mid(Str, i, 1) = " " Then
        k = k + 1
        If k = 1 Then a = Left(Str, i - 1)
        b = Right(Str, Len(Str) - i)
        ReDim Preserve Arr(1 To k)
        Arr(k) = Mid(Str, i + 1, 1)
    End If
Next
If k > 0 Then
    If k > 1 Then
        ReDim Preserve Arr(1 To k - 1)
        Rutgon = bodau(b & "." & Join(Arr, "") & "." & a) 'đã sửa đoạn này
    Else
        Rutgon = bodau(b & "." & a)
    End If
End If
End Function
Function bodau(chuoi As String) As String
Dim i As Long, Arr(1 To 26, 1 To 2)
Dim j As Long, Str As String

For i = 1 To 26
    Arr(i, 1) = ChrW(i + 96)
    Arr(i, 2) = ChrW(i + 96)
Next
For j = 1 To Len(chuoi)
    If Mid(chuoi, j, 1) = "." Then
        Str = Str & Mid(chuoi, j, 1)
    Else
        Str = Str & WorksheetFunction.VLookup(Mid(chuoi, j, 1), Arr, 2, 1)
    End If
Next
bodau = Str
End Function
 
Function TenVietTat(ByVal ten As String) As String
Dim a, i
a = Split(ten, " ")
Select Case UBound(a)
Case 0 ' chỉ có họ
TenVietTat = ten
Case 1 ' chỉ có họ và tên
TenVietTat = a(1) & "." & a(0)
Case Else ' có đủ hết
For i = 1 To UBound(a) - 1
TenVietTat = TenVietTat & Left(a(i), 1)
Next i
TenVietTat = a(UBound(a)) & "." & TenVietTat & "." & a(0)
End Select
'TenVietTat = TrietDau(LCase(TenVietTat)) ' hàm triệt dấu ở đây có cả đống, khỏi viết lại
End Function
 
VetMini đã viết:
Function TenVietTat(ByVal ten As String) As String
Dim a, i
a = Split(ten, " ")
Select Case UBound(a)
Case 0 ' chỉ có họ
TenVietTat = ten
Case 1 ' chỉ có họ và tên
TenVietTat = a(1) & "." & a(0)
Case Else ' có đủ hết
For i = 1 To UBound(a) - 1
TenVietTat = TenVietTat & Left(a(i), 1)
Next i
TenVietTat = a(UBound(a)) & "." & TenVietTat & "." & a(0)
End Select
'TenVietTat = TrietDau(LCase(TenVietTat)) ' hàm triệt dấu ở đây có cả đống, khỏi viết lại
End Function
Nhấp chuột vào đây để mở rộng...
Có thể dùng "RegExp" để triệt dấu trong trường hợp này không bác? em cũng đã tìm hiểu nhưng do không rành về vụ này lắm nên đành dùng worksheetfunction ạ.
 
nguyenthuy13388 đã viết:
Có thể dùng "RegExp" để triệt dấu trong trường hợp này không bác? em cũng đã tìm hiểu nhưng do không rành về vụ này lắm nên đành dùng worksheetfunction ạ.
Nhấp chuột vào đây để mở rộng...
RegExxp cũng phải liệt ra một đống ký tự. Dùng hàm Application.Match/VLookup/Lookup tiện hơn.
 
Bạn có thể tham khảo sử dụng hàm dưới đây:



---------------------
PHP: 
Public Function ShortName(Text As String, _
           Optional ByVal Delimiter As String = " ", _
           Optional ByVal SpaceChar As String = ".") As String
  Dim a As String, e As String, i As String, o As String, u As String, y As String, d As String
  a = "[aA" & ChrW(224) & ChrW(225) & ChrW(226) & ChrW(227) & ChrW(259) & ChrW(7841) & ChrW(7843) & ChrW(7845) & ChrW(7847) & ChrW(7849) & ChrW(7851) & ChrW(7853) & ChrW(7855) & ChrW(7857) & ChrW(7859) & ChrW(7861) & ChrW(7863) & ChrW(65) & ChrW(192) & ChrW(193) & ChrW(194) & ChrW(195) & ChrW(258) & ChrW(7840) & ChrW(7842) & ChrW(7844) & ChrW(7846) & ChrW(7848) & ChrW(7850) & ChrW(7852) & ChrW(7854) & ChrW(7856) & ChrW(7858) & ChrW(7860) & ChrW(7862) & "]"
  e = "[eE" & ChrW(232) & ChrW(233) & ChrW(234) & ChrW(7865) & ChrW(7867) & ChrW(7869) & ChrW(7871) & ChrW(7873) & ChrW(7875) & ChrW(7877) & ChrW(7879) & ChrW(200) & ChrW(201) & ChrW(202) & ChrW(7864) & ChrW(7866) & ChrW(7868) & ChrW(7870) & ChrW(7872) & ChrW(7874) & ChrW(7876) & ChrW(7878) & "]"
  i = "[iI" & ChrW(236) & ChrW(237) & ChrW(297) & ChrW(7881) & ChrW(7883) & ChrW(204) & ChrW(205) & ChrW(296) & ChrW(7880) & ChrW(7882) & "]"
  o = "[oO" & ChrW(242) & ChrW(243) & ChrW(244) & ChrW(245) & ChrW(417) & ChrW(7885) & ChrW(7887) & ChrW(7889) & ChrW(7891) & ChrW(7893) & ChrW(7895) & ChrW(7897) & ChrW(7899) & ChrW(7901) & ChrW(7903) & ChrW(7905) & ChrW(7907) & ChrW(210) & ChrW(211) & ChrW(212) & ChrW(213) & ChrW(416) & ChrW(7884) & ChrW(7886) & ChrW(7888) & ChrW(7890) & ChrW(7892) & ChrW(7894) & ChrW(7896) & ChrW(7898) & ChrW(7900) & ChrW(7902) & ChrW(7904) & ChrW(7906) & "]"
  u = "[uU" & ChrW(249) & ChrW(250) & ChrW(361) & ChrW(432) & ChrW(7909) & ChrW(7911) & ChrW(7913) & ChrW(7915) & ChrW(7917) & ChrW(7919) & ChrW(7921) & ChrW(217) & ChrW(218) & ChrW(360) & ChrW(431) & ChrW(7908) & ChrW(7910) & ChrW(7912) & ChrW(7914) & ChrW(7916) & ChrW(7918) & ChrW(7920) & "]"
  y = "[yY" & ChrW(253) & ChrW(7923) & ChrW(7925) & ChrW(7927) & ChrW(7929) & ChrW(221) & ChrW(7922) & ChrW(7924) & ChrW(7926) & ChrW(7928) & "]"
  d = "[dD" & ChrW(273) & ChrW(272) & "]"
  Dim S1 As String, S2 As String, S As String, SP() As String
  Dim L1 As Integer, L2 As Integer, L3 As Integer, b As Boolean, Dot As String
  SP = Split(Text, Delimiter): L2 = UBound(SP)
  For L1 = 1 To Len(Text)
    S1 = Mid(Text, L1, 1)
    If S1 = Delimiter Then
      L3 = L3 + 1:
      If L3 = L2 And L3 > 1 Then
        Dot = SpaceChar 
      ElseIf (L2 > 0 And L3 = 1) Then
        Dot = SpaceChar: b = True
      ElseIf L3 > 0 And L3 < L2 Then
        b = True
      End If
    Else
      If b Or L3 = 0 Or (L3 > 0 And L3 = L2) Then
        Select Case True
        Case S1 Like a: S1 = "a"
        Case S1 Like e: S1 = "e"
        Case S1 Like i: S1 = "i"
        Case S1 Like o: S1 = "o"
        Case S1 Like u: S1 = "u"
        Case S1 Like y: S1 = "y"
        Case S1 Like d: S1 = "d"
        End Select
        S2 = S2 & Dot & S1
        b = False: Dot = ""
      End If
    End If
  Next
  ShortName = S2
End Function
 
Lần chỉnh sửa cuối:
Hàm TrietDau đại khái nó như vầy:

Function TrietDau(s As String) As String
Dim i as long
TrietDau = s
For i = 1 To Len(s)
Mid(TrietDau, i, 1) = SimpleLatinise(Mid(TrietDau, i, 1))
Next i
End Function

Function SimpleLatinise(c As String) As String
' cuts the diacritic marks from a Vietnamese Unicode Character
If c = "" Then Exit Function
Select Case AscW(c)
Case 0 To 127 ' quick escape. As the majority of characters are simplem Latin anyway
SimpleLatinise = c
Case 273
SimpleLatinise = "d"
Case 272
SimpleLatinise = "D"
Case 224, 225, 226, 227, 259, 7841, 7843, 7845, 7847, 7849, 7851, 7853, 7855, 7857, 7859, 7861, 7863
SimpleLatinise = "a"
Case 192, 193, 194, 195, 258, 7840, 7842, 7844, 7846, 7848, 7850, 7852, 7854, 7856, 7858, 7860, 7862
SimpleLatinise = "A"
Case 232, 233, 234, 7865, 7867, 7869, 7871, 7873, 7875, 7877, 7879
SimpleLatinise = "e"
Case 200, 201, 202, 7864, 7866, 7868, 7870, 7872, 7874, 7876, 7878
SimpleLatinise = "E"
Case 236, 237, 297, 7881, 7883
SimpleLatinise = "i"
Case 204, 205, 296, 7880, 7882
SimpleLatinise = "I"
Case 242, 243, 244, 245, 417, 7885, 7887, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907
SimpleLatinise = "o"
Case 210, 211, 212, 213, 416, 7884, 7886, 7888, 7890, 7892, 7894, 7896, 7898, 7900, 7902, 7904, 7906
SimpleLatinise = "O"
Case 249, 250, 361, 432, 7909, 7911, 7913, 7915, 7917, 7919, 7921
SimpleLatinise = "u"
Case 217, 218, 360, 431, 7908, 7910, 7912, 7914, 7916, 7918, 7920
SimpleLatinise = "U"
Case 253, 7923, 7925, 7927, 7929
SimpleLatinise = "y"
Case 221, 7922, 7924, 7926, 7928
SimpleLatinise = "Y"
Case Else
SimpleLatinise = c
End Select
End Function
 
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

A
Đếm dữ liệu với điều kiện
Trả lời
11
Đọc
86
DeTong
D
A
Excel thiếu dữ liệu
Trả lời
2
Đọc
49
Hoàng Tuấn 868
H
Maika8008
  • Question
Add-In .xlam trộn dữ liệu Excel vào Word
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
29
Đọc
2K
vu_tuan_manh_linh
vu_tuan_manh_linh
T
V/v tối ưu xử lý đoạn code
Trả lời
4
Đọc
150
huhumalu
H
H
  • Question
nhờ các bác viết mẫu cho em lệnh dùng checkbox để rút ngắn thời gian thao tác
Trả lời
16
Đọc
387
giaiphap
giaiphap
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom