Cách tìm và xóa duplicate words trong 1 chuỗi từ?

[sousukesolid]

Hi các bác,
Các bác cho tớ hỏi có cái script nào để có thể check và highlight từ giống nhau trong 1 chuỗi text ở cùng 1 cell trên excel không? tớ có tìm trên mạng thì chỉ cách tạo function trên VB rồi chaỵ ở excel, nhưng cái function mà tớ có thì chỉ có thể xóa duplicate nếu 2 từ giống nhau đứng cạnh nhau mà thôi. Cụ thể:

Cách trên mạng chỉ:
One One Two Two Three Three --> One Two Three

Yêu cầu cần thiết:
One Two Three One Two Three One One Three Two--> One Two Three One Two Three One One Three Two

Xin các bác giúp đỡ, thanks các bác nhiều.

 

[ndu96081631]

Hi các bác,
Các bác cho tớ hỏi có cái script nào để có thể check và highlight từ giống nhau trong 1 chuỗi text ở cùng 1 cell trên excel không? tớ có tìm trên mạng thì chỉ cách tạo function trên VB rồi chaỵ ở excel, nhưng cái function mà tớ có thì chỉ có thể xóa duplicate nếu 2 từ giống nhau đứng cạnh nhau mà thôi. Cụ thể:

Cách trên mạng chỉ:
One One Two Two Three Three --> One Two Three

Yêu cầu cần thiết:
One Two Three One Two Three One One Three Two--> One Two Three One Two Three One One Three Two

Xin các bác giúp đỡ, thanks các bác nhiều.

Đương nhiên là được rồi! Hàm này:

Function StrUnique(Text As String, Optional Sep) As String
  Dim i As Long, Temp
  On Error Resume Next
  If IsMissing(Sep) Then
    StrUnique = Left(Text, 1)
    For i = 1 To Len(Text)
      If InStr(StrUnique, Mid(Text, i, 1)) = 0 Then StrUnique = StrUnique & Mid(Text, i, 1)
    Next i
  Else
    Temp = Split(WorksheetFunction.Trim(Replace(Text, CStr(Sep), " ")), " ")
    With CreateObject("Scripting.Dictionary")
      For i = 0 To UBound(Temp)
        .Add Temp(i), ""
      Next i
      StrUnique = Join(.Keys, Sep)
    End With
  End If
End Function

Khả năng của hàm:
Chuổi One Two Three One Two Three One One Three Two ---> One Two Three
Chuổi zbcabbzc ---> abcz

 

[hoangdanh282vn]

Nếu như yêu cầu của tác giả là tô màu từ bị trùng trong chuỗi thì dùng code sau : bôi chọn vùng cần tô màu và bấm nút.

Sub ToMau()
Dim Cell As Range, i As Long, k As Long
Dim Str() As String
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cell In Selection
    Str = Split(Cell.Value, " ")
    Dic.RemoveAll
    k = 0
    For i = 0 To UBound(Str())
        If Not Dic.Exists(Str(i)) Then
            Dic.Add Str(i), Nothing
        Else
            Cell.Characters(Start:=k + 1, Length:=Len(Str(i))).Font.ColorIndex = 3
        End If
        k = k + Len(Str(i)) + 1
    Next i
Next Cell
End Sub

Nếu là xóa từ trùng trong chuỗi thì dùng code sau :

Sub XoaTrung()
Dim Cell As Range, i As Long, S As String
Dim Str() As String
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cell In Selection
    Str = Split(Cell.Value, " ")
    Dic.RemoveAll
    For i = 0 To UBound(Str())
        If Not Dic.Exists(Str(i)) Then
            Dic.Add Str(i), Nothing
            S = S & " " & Str(i)
        End If
    Next i
    Cell.Value = Trim(S)
Next Cell
End Sub

 

[ThuNghi]

Đương nhiên là được rồi! Hàm này:

Function StrUnique(Text As String, Optional Sep) As String
  Dim i As Long, Temp
  On Error Resume Next
  If IsMissing(Sep) Then
    StrUnique = Left(Text, 1)
    For i = 1 To Len(Text)
      If InStr(StrUnique, Mid(Text, i, 1)) = 0 Then StrUnique = StrUnique & Mid(Text, i, 1)
    Next i
  Else
    Temp = Split(WorksheetFunction.Trim(Replace(Text, CStr(Sep), " ")), " ")
    With CreateObject("Scripting.Dictionary")
      For i = 0 To UBound(Temp)
        .Add Temp(i), ""
      Next i
      StrUnique = Join(.Keys, Sep)
    End With
  End If
End Function

Khả năng của hàm:
Chuổi One Two Three One Two Three One One Three Two ---> One Two Three
Chuổi zbcabbzc ---> abcz

Cám ơn nhiều, hay quá, sao mình cũng add Key,"" mà nó không chịu nó bắt phải khai thêm if cụ thể như

Function TachChu(rng As Range) As String
Dim iStr As String, iTach As String, iArr() As String, i As Long
iStr = Trim(rng)
If Len(iStr) = 0 Then
iTach = ""
End If
iArr = Split(iStr, Space(1))
With CreateObject("Scripting.Dictionary")
For i = 0 To UBound(iArr)
If Not .Exists(iArr(i)) Then .Add iArr(i), ""
Next i
iTach = Join(.Keys, Space(1))
End With
Erase iArr
TachChu = iTach
End Function

 

[ndu96081631]

Cám ơn nhiều, hay quá, sao mình cũng add Key,"" mà nó không chịu nó bắt phải khai thêm if cụ thể như

Thích IF thì ghi rõ ràng cũng tốt... nhưng khi đã hiểu RẤT RÕ về NGUYÊN TẮC, ta có thể ăn gian bằng cách On Error Resume Next ở đầu code cũng đâu có sao! Khi có Key trùng sẽ gặp lỗi và nó sẽ cho qua luôn

 

[doquocdan]

Mọi người cho em hỏi vơi: em có một cột chứa các số có 1 đơn vị. làm thế náo mà mình có thể xuất sang cột bên cạnh chỉ có 10 con số. ví dụ có cột a là 151643535664 thì muốn xuất sang cột b là 15643. mỗi só một ô các anh nhé kể cả Data ỏ cột A cũng là mỗi số 1 ô.