Giúp code: Dựa vào bảng tra để viết tắt Tên! (1 người xem)

Hong.Van · 16/1/13

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!

huuthang_bd · 16/1/13

Dùng UDF cho linh hoạt nhé.

PHP:

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

Mã:

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

Hoàng Trọng Nghĩa · 16/1/13

Bạn thử code này xem:

Mã:

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

SA_DQ · 16/1/13

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!

ndu96081631 · 16/1/13

huuthang_bd đã viết:
Dùng UDF cho linh hoạt nhé.

PHP:

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

Mã:

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

Kết quả còn sai rất nhiều
Ví dụ:
Cty TNHH TM TBVT Vũ Lộc cho kết quả là Cty TBVT Vũ Lộc (mà lý ra phải là: Cty Vũ Lộc)
Cty TNHH TM & TTNT Trung Á Sài Gòn cho kết quả là Cty & Trung Á Sài Gòn (mà lý ra phải là: Cty Trung Á Sài Gòn)
vân vân
----------------
Tôi nghĩ điều đầu tiên tác giả cần làm là:
- Xem kỹ lại bảng tra (viết chính xác các từ cần thay thế)
- Nên sort lại bảng tra theo độ dài chuổi. Chuổi dài nhất nằm trên cùng và chuổi ngắn nhất nằm dưới cùng

Hoàng Trọng Nghĩa · 16/1/13

HYen17 đã viết:
(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!

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?

SA_DQ · 16/1/13

- Nên sort lại bảng tra theo độ dài chuổi. Chuổi dài nhất nằm trên cùng và chuổi ngắn nhất nằm dưới cù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!

[ThongBao] 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? [/thongbao]

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

Hoàng Trọng Nghĩa · 16/1/13

HYen17 đã viết:
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.

huuthang_bd · 16/1/13

Hoàng Trọng Nghĩa đã viết:
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?

Tôi chạy thử thấy có đúng đâu //////

huuthang_bd · 16/1/13

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ũ.

PHP:

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.

Hoàng Trọng Nghĩa · 16/1/13

huuthang_bd đã viết:
Tôi chạy thử thấy có đúng đâu

Đú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:

Mã:

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:

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

Hoàng Trọng Nghĩa · 16/1/13

huuthang_bd đã viết:
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ũ.

PHP:

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.

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.

ChanhTQ@ · 16/1/13

Ngoại trừ tác giả, mình muốn nhắc với các bạn có bài trong topic này 1 điều là

(/ới tác giả bài này, ta chỉ nên quăng cho cái cần câu & nếu còn tối bụng thì nhủ thêm 1 câu:
"Ê, đi mà câu lấy cá!"

hoamattroicoi · 16/1/13

ChanhTQ@ đã viết:
(/ới tác giả bài này, ta chỉ nên quăng cho cái cần câu & nếu còn tối bụng thì nhủ thêm 1 câu:
"Ê, đi mà câu lấy cá!"

Hoá ra ngày xưa mình bị quăng cần câu hoài mà không biết, hì hì hì. Cảm ơn bác Chanh nhìu ^^

Kết quả thì có rồi nhưng bài này với gợi ý thuật toán của chị HYEN thì chắc bạn Hong.Van xơi ngon bác ChanhTQ nhỉ, hiiiiiiiiiiii

huuthang_bd · 16/1/13

Hoàng Trọng Nghĩa đã viết:
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.

Nói vậy mà cũng... nói !$@!!

hoamattroicoi đã viết:
Hoá ra ngày xưa mình bị quăng cần câu hoài mà không biết, hì hì hì. Cảm ơn bác Chanh nhìu ^^

Kết quả thì có rồi nhưng bài này với gợi ý thuật toán của chị HYEN thì chắc bạn Hong.Van xơi ngon bác ChanhTQ nhỉ, hiiiiiiiiiiii

Lại chị HYEN kìa --=0

Quang_Hải · 16/1/13

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

PHP:

Sub Ten_Tat()
Dim data(), i, j, Res(), temp1, temp2
With Sheet2
   .Range(.[I3], .[I65536].End(3)).Offset(, -1) = [Row(a:a)]
   .Range(.[I3], .[I65536].End(3)).Offset(, 1).FormulaR1C1 = "=LEN(RC[-1])"
   .Range(.[H3], .[H65536].End(3)).Resize(, 3).Sort .[J2], 2
   data = .Range(.[I3], .[I65536].End(3).Offset(1)).Value
   .Range(.[H3], .[H65536].End(3)).Offset(, 2).ClearContents
   .Range(.[H3], .[H65536].End(3)).Resize(, 3).Sort .[H2], 1
End With
data(UBound(data), 1) = "&"
Res = Sheet1.Range(Sheet1.[B4], Sheet1.[B65536].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.[G4].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.

PHP:

Sub Ten_Tat2()
Dim data(), i, j, Res(), temp1, temp2
With Sheet2
   .Range(.[I3], .[I65536].End(3)).Sort .[I2], 2
   data = .Range(.[I3], .[I65536].End(3).Offset(1)).Value
End With
data(UBound(data), 1) = "&"
Res = Sheet1.Range(Sheet1.[B4], Sheet1.[B65536].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.[G4].Resize(i - 1) = Res
End Sub

dhn46 · 16/1/13

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

Mã:

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

Quang_Hải · 16/1/13

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

huuthang_bd · 16/1/13

dhn46 đã viết:

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

Mã:

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.

quanghai1969 đã viết:
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.

Hoàng Trọng Nghĩa · 16/1/13

huuthang_bd đã viết:
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.

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.

ChanhTQ@ · 16/1/13

[thongBao]Hình như bài này mà không sort dữ liệu thì không được đâu.
[/thongBao]

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ế;

Hong.Van · 17/1/13

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!

Giúp code: Dựa vào bảng tra để viết tắt Tên! (1 người xem)

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

Busy

File đính kèm

Chuyên gia GPE

Chuyên gia GPE

/(hông là gì!

Huyền thoại GPE

Chuyên gia GPE

/(hông là gì!

Chuyên gia GPE

Chuyên gia GPE

Chuyên gia GPE

Chuyên gia GPE

File đính kèm

Chuyên gia GPE

0901452không62

Thành viên gắn bó

Chuyên gia GPE

Thành viên gạo cội

Hướng tới tương lai

Thành viên gạo cội

Chuyên gia GPE

Chuyên gia GPE

0901452không62

Busy

Thời gian đếm ngược.