Giúp code: Dựa vào bảng tra để viết tắt Tên!

One Response

1. hands says:

   20/12/2022 at 4:12 pm

   Em chào Thầy cô & Anh chị!
   Vui lòng viết giúp code cho em như sau:
   Tại Sheet DS cột B, em có danh sách tên Cty, do tên này thường qúa dài nên khi em nối chuỗi thì nó dài quá!
   Bây giờ em lập bảng tra tại cột I của Sheet MA, bảng này dùng để liệt kê các từ cần lọai bỏ, khi chuyển 1 tên Cty bình thường sang viết tắt.
   VD: bên bảng tra (cột I của Sheet MA) có chữ "TNHH" thì tại sheet DS cột F (cột kết quả chạy code) sẽ lấy tên cty tại cột B và bỏ chữ "TNHH"
   Cty TNHH Hồng Vân thì kết qủa là Cty Hồng Vân
   ————-
   Lưu ý: Bảng tra của em còn có thể thêm nhiều từ khác
   Xin xem File đính kèm
   Em cảm ơn!

   Bạn thử code này xem:

   Sub Test()
         Dim ArrFull As Variant, ArrItm As Variant
         Dim h As Long, r As Long, ubd1 As Long, ubd2 As Long
   
   ArrItm = Range(Sheet2.[I3], Sheet2.[I65536].End(xlUp)).Value
         ArrFull = Range(Sheet1.[B3], Sheet1.[B65536].End(xlUp)).Value
   
   ubd1 = UBound(ArrItm)
         ubd2 = UBound(ArrFull)
   
   For r = 1 To ubd1
               For h = 1 To ubd2
                     ArrFull(h, 1) = Replace(ArrFull(h, 1), ArrItm(r, 1) & " ", "")
               Next
         Next
   
   Sheet1.[F3].Resize(ubd2, 1).Value = ArrFull
   End Sub

   http://www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-code-d%E1%BB%B1a-v%C3%A0o-b%E1%BA%A3ng-tra-%C4%91%E1%BB%83-vi%E1%BA%BFt-t%E1%BA%AFt-t%C3%AAn.76285/post-468728

   Mình gợi í bạn cách làm dân dã sau, bạn thử xem:

   (1) Xếp cột 'BangTra' của trang 'Ma' theo chiều tăng dần;

   (2) Gán vùng cần thay vô biến Range nào đó đã khai báo (VD Rng);

   (3) Tạo vòng lặp duyệt trị chuỗi trong cột 'BangTra' này từ dưới lên

   (4) Tiến hành tìm kiếm trong Rng, thành tố chuỗi đang duyệt

   (5) Thấy thì thay thôi & còn thấy thì còn thay

   Giả thuật này bạn thừa sức làm & ăn tiền nhất là cụm từ tô màu đỏ đó nhe.

   Các bạn thử xem sao!

   Dùng UDF cho linh hoạt nhé.
   Function TenTat(Str As String, Arr)
   Dim Obj, Item
   Set Obj = CreateObject("VBScript.RegExp")
   For Each Item In Arr
   Obj.Pattern = Obj.Pattern & "|" & Item
   Next
   Obj.Pattern = Replace(Obj.Pattern, "|", "", 1, 1)
   Obj.Global = True
   Obj.IgnoreCase = True
   TenTat = WorksheetFunction.Trim(Obj.Replace(Str, ""))
   Set Obj = Nothing
   End Function
   Tại F4 bạn nhập công thức

   =TenTat(B4,MA!$I$3:$I$20)

   Kết quả còn sai rất nhiều
   Ví dụ:
   Cty TNHH TM TBVT Vũ Lộc cho kết quả là Cty TBVT Vũ Lộc (mà lý ra phải là: Cty Vũ Lộc)
   Cty TNHH TM & TTNT Trung Á Sài Gòn cho kết quả là Cty & Trung Á Sài Gòn (mà lý ra phải là: Cty Trung Á Sài Gòn)
   vân vân
   —————-
   Tôi nghĩ điều đầu tiên tác giả cần làm là:
   – Xem kỹ lại bảng tra (viết chính xác các từ cần thay thế)
   – Nên sort lại bảng tra theo độ dài chuổi. Chuổi dài nhất nằm trên cùng và chuổi ngắn nhất nằm dưới cùng

   http://www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-code-d%E1%BB%B1a-v%C3%A0o-b%E1%BA%A3ng-tra-%C4%91%E1%BB%83-vi%E1%BA%BFt-t%E1%BA%AFt-t%C3%AAn.76285/post-468737

   Em nghĩ, với bài #3 em làm thử vừa rồi đã đáp ứng hoàn toàn với dữ liệu của tác giả, vậy có cần thiết sắp xếp hay không?

   – Nên sort lại bảng tra theo độ dài chuổi. Chuổi dài nhất nằm trên cùng và chuổi ngắn nhất nằm dưới cùng

   Sort theo kiểu ABC cũng được, nhưng quan trọng là duyệt từ dưới lên.

   Còn làm từ trên làm xuống thì theo cách NDU!

   Kha, kha,. . . . SPAM 1 tí & nhờ MOD/SMOD xóa dùm!

   To Nghĩa: Em nghĩ, với bài #3 em làm thử vừa rồi đã đáp ứng hoàn toàn với dữ liệu của tác giả, vậy có cần thiết sắp xếp hay không?

   Sort khi không biết mảng là gì, chắc vậy . . . .

   Cái này là thủ tục cho cả vùng dữ liệu, chứ viết hàm, thì đơn giản và nhanh hơn nhiều! Miễn là đầu vào xác định và không nhất thiết phải sắp xếp vì đã duyệt từ gốc đến ngọn cả 2 mảng.

   Bạn dùng thử UDF này. Tôi sort dữ liệu trong code luôn. Cú pháp vẫn như cũ.
   Function TenTat(Str As String, Arr)
   Dim Obj, Tmp As String, i As Long, j As Long
   Set Obj = CreateObject("VBScript.RegExp")
   Arr = Arr.Value
   For i = 1 To UBound(Arr, 1)
   For j = i + 1 To UBound(Arr, 1)
   If Len(Arr(i, 1)) < Len(Arr(j, 1)) Then
   Tmp = Arr(i, 1): Arr(i, 1) = Arr(j, 1): Arr(j, 1) = Tmp
   End If
   Next
   Next
   For i = 1 To UBound(Arr, 1)
   Obj.Pattern = Obj.Pattern & "|" & Arr(i, 1)
   Next
   Obj.Pattern = Replace(Obj.Pattern, "|", "", 1, 1)
   Obj.Global = True
   Obj.IgnoreCase = True
   TenTat = WorksheetFunction.Trim(Obj.Replace(Str, ""))
   Set Obj = Nothing
   End Function
   Nếu dữ liệu đã được sort theo độ dài giảm dần thì bạn có thể dùng code cũ ở bài #2.

   http://www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-code-d%E1%BB%B1a-v%C3%A0o-b%E1%BA%A3ng-tra-%C4%91%E1%BB%83-vi%E1%BA%BFt-t%E1%BA%AFt-t%C3%AAn.76285/post-468757

   Hàm này gần như đúng tuyệt đối, tuy nhiên vẫn như Thầy NDU nói, nó vẫn sót lại chữ &

   Đây không phải là lỗi của Hàm mà chính là lỗi của Bảng Tra không đề cập vào.
   Đúng là chưa kiểm tra, vì mình dùng công thức để check, khổ nổi cái file này đã đặt Calculation = Manual mới đau! Toàn ra True mà thôi.

   Giờ kiểm tra lại, thấy rằng bạn này cần phải sửa lại bảng tra thôi, không nhất thiết phải sort nhưng phải thiết kế hợp lý, thay vì một mục là TNHH, mục kia là TNHH TMDV thì mục kia chỉ cần TMDV là đủ rồi, không cần lặp lại TNHH làm gì.

   Đây là thủ tục:

   Sub Test()
         Dim ArrFull As Variant, ArrItm As Variant
         Dim h As Long, r As Long, ubd1 As Long, ubd2 As Long
   
   ArrItm = Range(Sheet2.[K3], Sheet2.[K65536].End(xlUp)).Value
         ArrFull = Range(Sheet1.[B3], Sheet1.[B65536].End(xlUp)).Value
   
   ubd1 = UBound(ArrItm)
         ubd2 = UBound(ArrFull)
   
   For r = 1 To ubd1
               For h = 1 To ubd2
                     ArrFull(h, 1) = WorksheetFunction.Trim( _
                                     Replace(ArrFull(h, 1), _
                                     ArrItm(r, 1), "", , , vbTextCompare))
               Next
         Next
   
   Sheet1.[F3].Resize(ubd2, 1).Value = ArrFull
   End Sub

   Còn đây là Hàm:

   Function ComName(ByVal FullName As String, ByVal ReplaceArr As Variant) As String
   
   Dim Itm As Variant
   
   If IsArray(ReplaceArr) = False Then ReplaceArr = Array(ReplaceArr)
   
   ComName = FullName
         For Each Itm In ReplaceArr
               ComName = Replace(ComName, Itm, "", , , vbTextCompare)
         Next
   
   ComName = WorksheetFunction.Trim(ComName)
   End Function

   Thêm 1 thủ tục chẳng giống ai cho bạn tham khảo

   Sub Ten_Tat()
   Dim data(), i, j, Res(), temp1, temp2
   With Sheet2
   .Range(., ..End(3)).Offset(, -1) = [Row(a:a)]
   .Range(., ..End(3)).Offset(, 1).FormulaR1C1 = "=LEN(RC)"
   .Range(., ..End(3)).Resize(, 3).Sort ., 2
   data = .Range(., ..End(3).Offset(1)).Value
   .Range(., ..End(3)).Offset(, 2).ClearContents
   .Range(., ..End(3)).Resize(, 3).Sort ., 1
   End With
   data(UBound(data), 1) = "&"
   Res = Sheet1.Range(Sheet1., Sheet1..End(3)).Value
   For i = 1 To UBound(Res)
   For j = 1 To UBound(data)
   Res(i, 1) = Application.Trim(Replace(Res(i, 1), data(j, 1), "", , , 1))
   Next
   Next
   Sheet1..Resize(i – 1) = Res
   End Sub

   Vầy thì ngắn hơn chút. Nếu có thêm cột STT trước cột I thì sau khi xử lý sẽ trả cột I về trạng thái ban đầu.

   Sub Ten_Tat2()
   Dim data(), i, j, Res(), temp1, temp2
   With Sheet2
   .Range(., ..End(3)).Sort ., 2
   data = .Range(., ..End(3).Offset(1)).Value
   End With
   data(UBound(data), 1) = "&"
   Res = Sheet1.Range(Sheet1., Sheet1..End(3)).Value
   For i = 1 To UBound(Res)
   For j = UBound(data) To 1 Step -1
   Res(i, 1) = Application.Trim(Replace(Res(i, 1), data(j, 1), "", , , 1))
   Next
   Next
   Sheet1..Resize(i – 1) = Res
   End Sub

   http://www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-code-d%E1%BB%B1a-v%C3%A0o-b%E1%BA%A3ng-tra-%C4%91%E1%BB%83-vi%E1%BA%BFt-t%E1%BA%AFt-t%C3%AAn.76285/post-468877

   Nếu không sắp xếp thì em nghĩ Code này có thể giải quyết được

   Function Tach(str As String, Arr)
   Dim i As Long, Ptn As String
   Arr = Arr.Value
   For i = 1 To UBound(Arr, 1)
       Ptn = Ptn & Arr(i, 1) & " "
   Next
   With CreateObject("vbscript.regexp")
       .IgnoreCase = True
       .Global = True
       .Pattern = "s+"
       Ptn = .Replace(Ptn, "|")
       .Pattern = Ptn
       str = .Replace(str, "")
       .Pattern = "s+"
       str = .Replace(str, " ")
   End With
       Tach = Replace(str, "&", "")
   End Function

   To HuuThang:
   Thuật toán của bạn rất hay, nhưng mình nghĩ nên dùng hàm Join để tạo ra chuỗi cho pattern
   PTN = Join(Application.Transpose(Arr), "|")

   To HongVan:
   Mình nghĩ bạn nên thêm cái dấu "&" trong sheet MA thì tốt hơn. Hoặc là chuỗi PTN sẽ thế này
   PTN = Join(Application.Transpose(Arr), "|") & "|&"

   To dhn46:
   Hình như bài này mà không sort dữ liệu thì không được đâu. Mình test code của bạn rồi và kết quả không đúng

   Nếu không sắp xếp thì em nghĩ Code này có thể giải quyết được

   Function Tach(str As String, Arr)
   Dim i As Long, Ptn As String
   Arr = Arr.Value
   For i = 1 To UBound(Arr, 1)
       Ptn = Ptn & Arr(i, 1) & " "
   Next
   With CreateObject("vbscript.regexp")
       .IgnoreCase = True
       .Global = True
       .Pattern = "s+"
       Ptn = .Replace(Ptn, "|")
       .Pattern = Ptn
       str = .Replace(str, "")
       .Pattern = "s+"
       str = .Replace(str, " ")
   End With
       Tach = Replace(str, "&", "")
   End Function

   Tách ra vầy thì càng chết.
   Từ Cty SX Nghệ Đen thành Cty Đen là tiêu người ta rồi.

   To HuuThang:
   Thuật toán của bạn rất hay, nhưng mình nghĩ nên dùng hàm Join để tạo ra chuỗi cho pattern
   PTN = Join(Application.Transpose(Arr), "|")

   Sau nhiều lần sử dụng, bây giờ tôi không khoái sử dụng các hàm của Worksheet nữa.

   Thật ra dù các bạn làm gì đi nữa thì cũng sẽ có ít nhiều sai sót do chuỗi trùng chuỗi, ví dụ Công trình, người ta viết tắt CT nếu chuỗi là CTY CT CẢNG (CÔNG TY CÔNG TRÌNH CẢNG) nếu loại bỏ chữ CT đi thì kết quả sẽ là Y CẢNG

   Cho nên hàm chỉ hỗ trợ tương đối chứ không thể tuyệt đối trong trường hợp này.
   Nếu dữ liệu lộn xộn thì xếp lại sẽ nhanh hơn; Bằng không thì ghi đâu đó & kiểm tra,
   Nếu ngắn hơn thì bị ghi đè bằng cái hiện hành vô thay thế;

   Em xin cảm ơn sự giúp đỡ của các Thầy cô & Anh chị!
   Để cho kết qủa chuẩn khi áp dụng các code trên, thì ngay từ nguồn phải có dữ liệu chuẩn
   Muốn viết tắt những từ của 1 tên Cty nào thì nên viết tắt từ nguồn thì kết quả mới chuẩn
   VD: Cty TNHH Tổng Hợp Thương Mại, nếu bảng tra mà có "TNHH", "Tổng Hợp", "Thương Mại" thì kết qủa chỉ còn "Cty" thôi, như vậy từ bảng tra cũng nên chỉ có những từ viết tắt như "TH", "TM" …
   Em cảm ơn!

   Reply