Luyện tập Code VBA: Lọc ký tự trùng nhau trong chuỗi !

Liên hệ QC

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨
Tham gia
24/2/13
Bài viết
2,382
Được thích
3,532
Giới tính
Nam
Bài viết này dành cho các bạn đang học hoặc đam mê hoặc đang phát triển ứng Excel với VBA.
Nhằm luyện tập, học hỏi và phát triển thêm kỹ năng viết Code VBA với những bài tập đơn giản.

"Lọc ký tự trùng nhau trong chuỗi".
--------------------------------
Bài tập: Viết một hàm lọc chuỗi bất kỳ loại bỏ các ký tự trùng nhau trả về kết quả là một chuỗi chứa các ký tự duy nhất, phân biệt ký tự hoa thường và không phân biệt ký tự hoa thường. Và hãy tối ưu hàm một cách tốt nhất có thể.

Ví dụ:

1. "abcde" => "abcde"
2. "tương tư có tương tự suy tư" => ""tương cóựsuy"
3. "Bài hát: Thanh Xuân Của Tôi (Viral Clip) Ca sĩ: Đan Trường Nhạc Hoa, Lời Việt: Tăng Nhật Tuệ Camera: Kuke Hà - Ngọc Kim Lời bài hát: Cùng nhau ngắm mưa Đoạn đường đón đưa Cười cười nói nói vui như thế Thanh xuân lấp lánh như bụi mưa Cùng nhau đếm sao Một thời huyên náo Giật mình nhìn thời gian đã xoá Thanh xuân như chút gió ngọt ngào Ta đã gặp nhau để nói thương nhau Giữ cho nhau ký ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Tự do hát ca Bụi đường quê nhà Nghiêng nghiêng cánh chim bay trong gió Mưa bay lấp lánh những ngày xanh Thành đô nắng hoa Lòng người băng giá Nhiều lần giật mình trong nước mắt Thanh xuân hôm qua đã nhạt nhoà Ta đã gặp nhau để nói thương nhau Giữ cho nhau kí ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Thương vẫn thương vậy thôi Vì em đó thanh xuân của tôi."​
=> "Bài hát:TanXuâCủô(Vrlp)sĩĐườgNạcHo,LệăậmeKk-ọbùắđóvếxấụMộyêGìãúặểơữýứớầéũẳốDẫổdừqựòềí."​
=> "Bài hát:anXuâCủô(Vrlp)sĩĐườgạo,ệăậmeK-ọùắóếấụộyêìãúặểơữýứớầéũẳốDẫổừqựòềí." (Không phân biệt hoa thường)​

Yêu cầu:
1. Cú pháp phải tối ưu.
2. Bài giải có thể nhiều hàm Sử dụng hàm thuần VBA hoặc thư viện Regular Expressions hoặc một thư viện nào có thể
3. Ưu tiên tốc độ xử lý.

(có hoặc không có giải thích về thuật toán hoặc giải thuật đã sử dụng)



Ứng dụng của hàm: Nhận biết và đếm số ký tự đã sử dụng trong một bài thơ, bài viết, ...
--------------------------------
Mời các bạn tham gia!
 
Lần chỉnh sửa cuối:
Có phần thưởng hông?
"Lọc ký tự trùng nhau trong chuỗi"
mà câu này "tương tư có tương tự suy tư" ==>cóựsuy
Ví dụ 3:"X()ĩ,-ộúýựòềí"
 
Upvote 0
Bài viết này dành cho các bạn đang học hoặc đam mê hoặc đang phát triển ứng Excel với VBA.
Nhằm luyện tập, học hỏi và phát triển thêm kỹ năng viết Code VBA với những bài tập đơn giản.

"Lọc ký tự trùng nhau trong chuỗi".
--------------------------------
Bài tập: Viết một hàm lọc chuỗi bất kỳ loại bỏ các ký tự trùng nhau trả về kết quả là một chuỗi chứa các ký tự duy nhất, phân biệt ký tự hoa thường và không phân biệt ký tự hoa thường. Và hãy tối ưu hàm một cách tốt nhất có thể.

Ví dụ:

1. "abcde" => "abcde"
2. "tương tư có tương tự suy tư" => ""tương cóựsuy"
3. "Bài hát: Thanh Xuân Của Tôi (Viral Clip) Ca sĩ: Đan Trường Nhạc Hoa, Lời Việt: Tăng Nhật Tuệ Camera: Kuke Hà - Ngọc Kim Lời bài hát: Cùng nhau ngắm mưa Đoạn đường đón đưa Cười cười nói nói vui như thế Thanh xuân lấp lánh như bụi mưa Cùng nhau đếm sao Một thời huyên náo Giật mình nhìn thời gian đã xoá Thanh xuân như chút gió ngọt ngào Ta đã gặp nhau để nói thương nhau Giữ cho nhau ký ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Tự do hát ca Bụi đường quê nhà Nghiêng nghiêng cánh chim bay trong gió Mưa bay lấp lánh những ngày xanh Thành đô nắng hoa Lòng người băng giá Nhiều lần giật mình trong nước mắt Thanh xuân hôm qua đã nhạt nhoà Ta đã gặp nhau để nói thương nhau Giữ cho nhau kí ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Thương vẫn thương vậy thôi Vì em đó thanh xuân của tôi."​
=> "Bài hát:TanXuâCủô(Vrlp)sĩĐườgNạcHo,LệăậmeKk-ọbùắđóvếxấụMộyêGìãúặểơữýứớầéũẳốDẫổdừqựòềí."​
=> "Bài hát:anXuâCủô(Vrlp)sĩĐườgạo,ệăậmeK-ọùắóếấụộyêìãúặểơữýứớầéũẳốDẫổừqựòềí." (Không phân biệt hoa thường)​

Yêu cầu:
1. Cú pháp phải tối ưu.
2. Bài giải có thể nhiều hàm Sử dụng hàm thuần VBA hoặc thư viện Regular Expressions hoặc một thư viện nào có thể
3. Ưu tiên tốc độ xử lý.

(có hoặc không có giải thích về thuật toán hoặc giải thuật đã sử dụng)

--------------------------------
Mời các bạn tham gia!
Bài này tôi làm khá lâu rồi, thậm chí vừa lọc duy nhất vừa sort luôn
Để xem bạn và mọi người làm thế nào, tôi cũng muốn học hỏi thêm
 
Upvote 0
Mình thử nộp bài:
Mã:
Function Vidu1$(ByVal Str$, Optional ByVal sens As VbCompareMethod = vbTextCompare)
    Dim kq$, s$, i&, n&
    n = Len(Str)
    If n < 2 Then
        Vidu1 = Str
        Exit Function
    End If
    kq = Left(Str, 1)
    For i = 2 To n
        s = Mid(Str, i, 1)
        If InStrRev(kq, s, , sens) = 0 Then kq = kq & s
    Next
    Vidu1 = kq
End Function
Function Vidu2$(ByVal Str$, Optional ByVal sens As VbCompareMethod = vbTextCompare)
    Static dic As Dictionary
    Dim i&, n&
    If dic Is Nothing Then
        Set dic = New Dictionary
    End If
    dic.CompareMode = sens
    n = Len(Str)
    If n = 0 Then
        Vidu2 = ""
        Exit Function
    End If
    For i = 1 To n
        dic.Item(Mid(Str, i, 1)) = vbNull
    Next
    Vidu2 = Join(dic.Keys, "")
    dic.RemoveAll
End Function
Function Vidu3$(Str$, Optional ByVal sens As VbCompareMethod = vbTextCompare)
    Dim s As String
    Do While Len(Str) > 0
        s = Left(Str, 1)
        Vidu3 = Vidu3 & s
        Str = Join(Split(Str, s, , sens), "")
    Loop
End Function
 

File đính kèm

  • LocChuoi.xlsm
    16 KB · Đọc: 40
Upvote 0
Mình thử nộp bài:
Mã:
Function Vidu1$(ByVal Str$, Optional ByVal sens As VbCompareMethod = vbTextCompare)
    Dim kq$, s$, i&, n&
    n = Len(Str)
    If n < 2 Then
        Vidu1 = Str
        Exit Function
    End If
    kq = Left(Str, 1)
    For i = 2 To n
        s = Mid(Str, i, 1)
        If InStrRev(kq, s, , sens) = 0 Then kq = kq & s
    Next
    Vidu1 = kq
End Function
Function Vidu2$(ByVal Str$, Optional ByVal sens As VbCompareMethod = vbTextCompare)
    Static dic As Dictionary
    Dim i&, n&
    If dic Is Nothing Then
        Set dic = New Dictionary
    End If
    dic.CompareMode = sens
    n = Len(Str)
    If n = 0 Then
        Vidu2 = ""
        Exit Function
    End If
    For i = 1 To n
        dic.Item(Mid(Str, i, 1)) = vbNull
    Next
    Vidu2 = Join(dic.Keys, "")
    dic.RemoveAll
End Function
Function Vidu3$(Str$, Optional ByVal sens As VbCompareMethod = vbTextCompare)
    Dim s As String
    Do While Len(Str) > 0
        s = Left(Str, 1)
        Vidu3 = Vidu3 & s
        Str = Join(Split(Str, s, , sens), "")
    Loop
End Function
Rất cảm ơn bạn đã tham gia.
 
Lần chỉnh sửa cuối:
Upvote 0
Bài viết này dành cho các bạn đang học hoặc đam mê hoặc đang phát triển ứng Excel với VBA.
Nhằm luyện tập, học hỏi và phát triển thêm kỹ năng viết Code VBA với những bài tập đơn giản.

"Lọc ký tự trùng nhau trong chuỗi".
--------------------------------
Bài tập: Viết một hàm lọc chuỗi bất kỳ loại bỏ các ký tự trùng nhau trả về kết quả là một chuỗi chứa các ký tự duy nhất, phân biệt ký tự hoa thường và không phân biệt ký tự hoa thường. Và hãy tối ưu hàm một cách tốt nhất có thể.

Ví dụ:

1. "abcde" => "abcde"
2. "tương tư có tương tự suy tư" => ""tương cóựsuy"
3. "Bài hát: Thanh Xuân Của Tôi (Viral Clip) Ca sĩ: Đan Trường Nhạc Hoa, Lời Việt: Tăng Nhật Tuệ Camera: Kuke Hà - Ngọc Kim Lời bài hát: Cùng nhau ngắm mưa Đoạn đường đón đưa Cười cười nói nói vui như thế Thanh xuân lấp lánh như bụi mưa Cùng nhau đếm sao Một thời huyên náo Giật mình nhìn thời gian đã xoá Thanh xuân như chút gió ngọt ngào Ta đã gặp nhau để nói thương nhau Giữ cho nhau ký ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Tự do hát ca Bụi đường quê nhà Nghiêng nghiêng cánh chim bay trong gió Mưa bay lấp lánh những ngày xanh Thành đô nắng hoa Lòng người băng giá Nhiều lần giật mình trong nước mắt Thanh xuân hôm qua đã nhạt nhoà Ta đã gặp nhau để nói thương nhau Giữ cho nhau kí ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Thương vẫn thương vậy thôi Vì em đó thanh xuân của tôi."​
=> "Bài hát:TanXuâCủô(Vrlp)sĩĐườgNạcHo,LệăậmeKk-ọbùắđóvếxấụMộyêGìãúặểơữýứớầéũẳốDẫổdừqựòềí."​
=> "Bài hát:anXuâCủô(Vrlp)sĩĐườgạo,ệăậmeK-ọùắóếấụộyêìãúặểơữýứớầéũẳốDẫổừqựòềí." (Không phân biệt hoa thường)​

Yêu cầu:
1. Cú pháp phải tối ưu.
2. Bài giải có thể nhiều hàm Sử dụng hàm thuần VBA hoặc thư viện Regular Expressions hoặc một thư viện nào có thể
3. Ưu tiên tốc độ xử lý.

(có hoặc không có giải thích về thuật toán hoặc giải thuật đã sử dụng)

--------------------------------
Mời các bạn tham gia!
Cũng tham gia cho vui
- Không phân biệt tốc độ có thể dùng regex như vậy:
Mã:
Sub a()
Dim str As String
str = [a1]
With CreateObject("vbscript.regexp")
    .ignorecase = True 'Không phân bi?t hoa thu?ng
    .Pattern = "((.).*)\2"
    Do While .test(str)
        str = .Replace(str, "$1")
    Loop
    MsgBox str
End With
End Sub
- Xét chuỗi bình thường dùng replace
Mã:
Sub b()
Dim str As String, i As Long
str = [a1]
For i = 1 To Len(str)
    str = Mid(str, 1, i) & Replace(Mid(str, i + 1, Len(str)), Mid(str, i, 1), "", , , 1) 'Không phân bi?t hoa thu?ng
Next
MsgBox str
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
excel_lv1.5 rất cảm ơn bạn đã tham gia

------------------------
Bài viết có yêu cầu cú pháp tuy nhiên khi nhìn qua code của hai bạn thì tôi nhận thấy khi viết hàm VBA thì các bạn lại bỏ qua lớp của Hàm, Hằng:
Ví dụ:
Left <= VBA.Left
Mid <= VBA.Mid
(Có hai dạng Mid tồn tại trong VBA, Mid nằm trước dấu bằng (=) là một phương thức và VBA.Mid là một hàm)
VbNullstring <= VBA.Constans.VbNullstring
Join <= VBA.Join
Dictionary <= Scripting.Dictionary
(Tất cả các code nên hoặc là luôn luôn phải đưa về Late Binding khi đến người dùng cuối - CreateObject("Scripting.Dictionary") )
....
Giải thích điểm này: Nếu các bạn đã viết thêm một hàm mới tương đương trả về kết quả tương đương thì viết là "Left" thì không sao.

Trường hợp gặp phải, VBA6 không có hàm Split:
#If VBA6 Then
Function Split()

End Function
#End If

Nếu bạn vô tình viết một hàm Left mới: nhưng kết quả trả về khác hàm Left VBA, nhưng trong toàn bộ dự án đều viết "Left" mà không phải "VBA.Left" thì sẽ lỗi.

------------------------


Tôi xin đưa ra giải thuật của mình để các bạn tham khảo


1. Sử dụng hàm căn bản trong VBA:

Giải thuật: Nhận ký tự đầu tiên, và thay thế ký tự đó trong chuỗi thành rỗng, cho đến khi chuỗi rỗng.​
Lúc này số vòng lặp sẽ tương đương với độ dài chuỗi kết quả.​
Hàm sử dụng:​
+ Hàm VBA Len: Để đếm độ dài chuỗi​
+ Hàm VBA Left: Để nhận ký tự đầu​
+ Hàm VBA Replace: Để xóa ký tự​
Giải thuật này bạn Hau151978 cũng đã sử dụng ở ví dụ 3, bạn ấy đã sử dụng Split để xóa ký tự và Join để nối chuỗi lại. Tuy nhiên thiếu "Byval" ở chuỗi đầu vào sẽ khó kiểm soát chuỗi khi ứng dụng thực tế.​

PHP:
Private Sub test_CharDuplicates()
  Dim I&, S$, T#
  On Error Resume Next
  For I = 0 To 65535
    If I <> 10 And I <> 13 Then S = S & VBA.ChrW$(I)
    DoEvents
  Next I
  Debug.Print VBA.Len(S)
  On Error GoTo 0
  T = Timer
  For I = 1 To 1
    Call CharDuplicates(S)
    DoEvents
  Next I
  Debug.Print Round(Timer - T, 5)
  T = Timer
  For I = 1 To 1
    'Call CharDuplicatesRE(S)'
    DoEvents
  Next I
  Debug.Print Round(Timer - T, 5)
End Sub
'Cách 1:'
Function CharDuplicates(ByVal Text As String, _
               Optional ByVal Compare As VBA.VbCompareMethod =  VBA.VbCompareMethod.vbBinaryCompare) As String
  Dim K As Long, s As String
  Do Until VBA.Len(Text) <= K
    s = VBA.Left$(Text, 1) 'VBA.Right$(Text, 1)'
    Text = VBA.Replace$(Text, s, VBA.Constants.vbNullString, , , Compare) & s 'Right => Text = s & ...'
    K = K + 1
  Loop
  CharDuplicates = Text
End Function
'Cách 2:
'Function CharDuplicates(ByVal Text As String, _
'               Optional ByVal Compare As VBA.VbCompareMethod = VBA.VbCompareMethod.vbBinaryCompare) As String
'  Dim T As String, S As String
'  Do While Text <> VBA.Constants.vbNullString
'    S = VBA.Left$(Text, 1) 'VBA.Right$(Text, 1)'
'    Text = VBA.Replace$(Text, S, VBA.Constants.vbNullString, , , Compare)
'    T = T & S 'Right => T = S & T'
'  Loop
'  CharDuplicates = T
'End Function
Function CharDuplicatesSort(ByVal Text As String, _
                Optional ByVal Compare As VBA.VbCompareMethod = VBA.VbCompareMethod.vbBinaryCompare) As String
  Dim S As String, P$(), K As Long
  ReDim P$(65535)
  Do While Text <> VBA.Constants.vbNullString
    S = VBA.Left$(Text, 1)
    Text = VBA.Replace$(Text, S, VBA.Constants.vbNullString, , , Compare)
    K = VBA.AscW(S)
    If K >= 0 Then
      P(K) = S
    Else
      ReDim Preserve P$(UBound(P) + 1)
      P(UBound(P)) = S
    End If
    DoEvents
  Loop
  CharDuplicatesSort = VBA.Join(P, "")
End Function
------------------------


2. Sử dụng thư viện Regular Expressions:
Giải thuật: sử dụng cú pháp "(?=.*\1)" - Có nhưng không lấy bất cứ ký tự nào kết hợp với Nhóm 1.​
Ví dụ:​
Pattern là "(a)(?=.*\1)"​
Thì ("a") chính là nhóm một, \1 là cú pháp đại diện cho nhóm 1​
Tương ứng: Pattern là "(a)(b)(?=.*\1\2)"​
PHP:
Function CharDuplicatesRE(ByVal Text As String, _
                 Optional ByVal IgnoreCase As Boolean = False, _
                 Optional ByVal Terminate As Boolean = False) As String
  Static RE As Object
  If RE Is Nothing Then
    Set RE = CreateObject("VBScript.RegExp")
  Else
    If Terminate Then Set RE = Nothing: Exit Function
  End If
  With RE
    .Global = True: .IgnoreCase = IgnoreCase: .MultiLine = True
    .Pattern = "(.)(?=.*\1)"
    CharDuplicatesRE = .Replace(Text, "")
  End With
End Function
---------------------------



Gợi ý thêm hàm Sắp xếp chuỗi:
---------------------------
PHP:
Public Function CharsSort(ByVal Text As String, _
                 Optional ByVal iDesc As Boolean = False, _
                 Optional ByVal Compare As  VbCompareMethod = vbCompareText) As String
  Dim i As Long, J As Long, L As Long, T1 As String, T2 As String, B As Variant
  L = VBA.Len(Text): If L < 2 Then GoTo Ends
  For i = 1 To L - 1: For J = i + 1 To L
    T1 = VBA.Mid$(Text, i, 1): T2 = VBA.Mid$(Text, J, 1)
    B = VBA.StrComp(T1,T2, Compare)
    If (Not iDesc And B = 1) Or (iDesc And B = -1) Then
      Mid(Text, J, 1) = T1: Mid(Text, i, 1) = T2
    End If
  Next J, i
Ends: CharsSort = Text
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Thực ra bài không khó. Cứ làm theo cách cần cù là sẽ ra kết quả. Vậy vấn đề nằm ở chỗ tốc độ. Thử sức với code tốc độ cao nhất có thể thôi.

Tôi hiểu là chủ thớt sẽ có trách nhiệm test tất cả các code và công bố kết quả cho "đám hiếu kỳ" biết. Tôi hiểu đúng?

Tôi thấy có lẽ các "các bạn đang học" sẽ ít tham gia. Ít ra là tới thời điểm bây giờ.

Nên test trên tập tin khủng một chút, vd. như tập tin tôi đính kèm, cỡ vài MB.
 

File đính kèm

  • data.rar
    1.5 MB · Đọc: 65
Upvote 0
Hehe de chúc em ngồi máy tính đưa file lên test tốc độ thử. Chủ topic cho vi dụ nào dài dài xíu
 
Upvote 0
Mạnh học được nhiều thứ còn cái món mì tôm cua này mấy lần quậy mà cứ tịt vậy đặt gạch lót dép ngồi nghe các sư phụ đàm đạo
 
Upvote 0
Thực ra bài không khó. Cứ làm theo cách cần cù là sẽ ra kết quả. Vậy vấn đề nằm ở chỗ tốc độ. Thử sức với code tốc độ cao nhất có thể thôi.

Tôi hiểu là chủ thớt sẽ có trách nhiệm test tất cả các code và công bố kết quả cho "đám hiếu kỳ" biết. Tôi hiểu đúng?

Tôi thấy có lẽ các "các bạn đang học" sẽ ít tham gia. Ít ra là tới thời điểm bây giờ.

Nên test trên tập tin khủng một chút, vd. như tập tin tôi đính kèm, cỡ vài MB.
Load cái file của anh là muốn hết giờ rồi còn thi thố gì nữa

Mạnh học được nhiều thứ còn cái món mì tôm cua này mấy lần quậy mà cứ tịt vậy đặt gạch lót dép ngồi nghe các sư phụ đàm đạo
Cái này nó cũng cần trong Delphi của anh đó, do anh chưa đụng tới thôi hàm Replace trong Delphi mà Text lớn rất là chậm hehehehe. Có một số hàm phải viết lại mà dùng
 
Upvote 0
excel_lv1.5 rất cảm ơn bạn đã tham gia

------------------------
Bài viết có yêu cầu cú pháp tuy nhiên khi nhìn qua code của hai bạn thì tôi nhận thấy khi viết hàm VBA thì các bạn lại bỏ qua lớp của Hàm, Hằng:
Ví dụ:
Left <= VBA.Left
Mid <= VBA.Mid
(Có hai dạng Mid tồn tại trong VBA, Mid nằm trước dấu bằng (=) là một phương thức và VBA.Mid là một hàm)
VbNullstring <= VBA.Constans.VbNullstring
Join <= VBA.Join
Dictionary <= Scripting.Dictionary
(Tất cả các code nên hoặc là luôn luôn phải đưa về Late Binding khi đến người dùng cuối - CreateObject("Scripting.Dictionary") )
....
Giải thích điểm này: Nếu các bạn đã viết thêm một hàm mới tương đương trả về kết quả tương đương thì viết là "Left" thì không sao.

Trường hợp gặp phải, VBA6 không có hàm Split:
#If VBA6 Then
Function Split()

End Function
#End If

Nếu bạn vô tình viết một hàm Left mới: nhưng kết quả trả về khác hàm Left VBA, nhưng trong toàn bộ dự án đều viết "Left" mà không phải "VBA.Left" thì sẽ lỗi.

------------------------


Tôi xin đưa ra giải thuật của mình để các bạn tham khảo


1. Sử dụng hàm căn bản trong VBA:

Giải thuật: Nhận ký tự đầu tiên, và thay thế ký tự đó trong chuỗi thành rỗng, cho đến khi chuỗi rỗng.​
Lúc này số vòng lặp sẽ tương đương với độ dài chuỗi kết quả.​
Hàm sử dụng:​
+ Hàm VBA Len: Để đếm độ dài chuỗi​
+ Hàm VBA Left: Để nhận ký tự đầu​
+ Hàm VBA Replace: Để xóa ký tự​
Giải thuật này bạn Hau151978 cũng đã sử dụng ở ví dụ 3, bạn ấy đã sử dụng Split để xóa ký tự và Join để nối chuỗi lại. Tuy nhiên thiếu "Byval" ở chuỗi đầu vào sẽ khó kiểm soát chuỗi khi ứng dụng thực tế.​

PHP:
Private Sub test_CharDuplicates()
  Dim I&, S$, T#
  On Error Resume Next
  For I = 1 To 65535
    S = S & VBA.ChrW$(I)
    DoEvents
  Next I
  Debug.Print VBA.Len(S)
  On Error GoTo 0
  T = Timer
  For I = 1 To 1
    Call CharDuplicates(S)
    DoEvents
  Next I
  Debug.Print Round(Timer - T, 5)
  T = Timer
  For I = 1 To 1
    'Call CharDuplicatesRE(S)'
    DoEvents
  Next I
  Debug.Print Round(Timer - T, 5)
End Sub
'Cách 1:'
Function CharDuplicates(ByVal Text As String, _
               Optional ByVal Compare As VBA.VbCompareMethod =  VBA.VbCompareMethod.vbBinaryCompare) As String
  Dim K As Long, s As String
  Do Until VBA.Len(Text) <= K
    s = VBA.Left$(Text, 1)
    Text = VBA.Replace$(Text, s, VBA.Constants.vbNullString, , , Compare) & s
    K = K + 1
  Loop
  CharDuplicates = Text
End Function
'Cách 2:
'Function CharDuplicates(ByVal Text As String, _
'               Optional ByVal Compare As VBA.VbCompareMethod = VBA.VbCompareMethod.vbBinaryCompare) As String
'  Dim T As String, S As String
'  Do While Text <> VBA.Constants.vbNullString
'    S = VBA.Left$(Text, 1)
'    Text = VBA.Replace$(Text, S, VBA.Constants.vbNullString, , , Compare)
'    T = T & S
'  Loop
'  CharDuplicates = T
'End Function
------------------------


2. Sử dụng thư viện Regular Expressions:
Giải thuật: sử dụng cú pháp "(?=.*\1)" - Có nhưng không lấy bất cứ ký tự nào kết hợp với Nhóm 1.​
Ví dụ:​
Pattern là "(a)(?=.*\1)"​
Thì ("a") chính là nhóm một, \1 là cú pháp đại diện cho nhóm 1​
Tương ứng: Pattern là "(a)(b)(?=.*\1\2)"​
PHP:
Function CharDuplicatesRE(ByVal Text As String, _
                 Optional ByVal IgnoreCase As Boolean = False, _
                 Optional ByVal Terminate As Boolean = False) As String
  Static RE As Object
  If RE Is Nothing Then
    Set RE = CreateObject("VBScript.RegExp")
  Else
    If Terminate Then Set RE = Nothing: Exit Function
  End If
  With RE
    .Global = True: .IgnoreCase = IgnoreCase: .MultiLine = True
    .Pattern = "(.)(?=.*\1)"
    CharDuplicatesRE = .Replace(Text, "")
  End With
End Function
---------------------------



Gợi ý thêm hàm Sắp xếp chuỗi:
(Lưu ý: Hãy tạo hai hàm như này ở hai Module khác nhau để vận dụng hai cách so sánh ở dạng Text hoặc dạng Binary - Option Compare Text hoặc Binary)
---------------------------
PHP:
Public Function CharsSort(ByVal Text As String, _
                 Optional ByVal iDesc As Boolean = False) As String
  'Create:'
  'CharsSortT in Module "Option Compare Text"'
  'CharsSortB in Module "Option Compare Binary"'
  'CharsSort - Add parameters: Optional ByVal CompareText As Boolean = False'
  Dim i As Long, J As Long, L As Long, T1 As String, T2 As String
  L = VBA.Len(Text): If L < 2 Then GoTo Ends
  For i = 1 To L - 1: For J = i + 1 To L
    T1 = VBA.Mid$(Text, i, 1): T2 = VBA.Mid$(Text, J, 1)
    If (Not iDesc And T1 > T2) Or (iDesc And T1 < T2) Then
      Mid(Text, J, 1) = T1: Mid(Text, i, 1) = T2
    End If
  Next J, i
Ends: CharsSort = Text
End Function
Hàm CharDuplicatesRE chắc chắn sai. Hãy chạy CharDuplicatesRE và CharDuplicates với dữ liệu lấy từ tập tin của tôi thì thấy 2 kết quả khác nhau. Vậy một trong 2 hàm là sai. Cụ thể hàm sai là CharDuplicatesRE.

Thấy mọi người gửi bài mà mình hoang mang quá. :D Thôi thì cũng rụt rè dự thi.

Mã:
Function batman1(ByVal text As String) As String
Dim k As Long, count As Long, kytu As String, result As String, dic As Object
    If Len(text) = 0 Then Exit Function
    result = String(Len(text), Chr(0))
    kytu = String(1, Chr(0))
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare ' khong phan biet hoa thuong
    For k = 1 To Len(text)
        Mid(kytu, 1, 1) = Mid(text, k, 1)
        If Not dic.Exists(kytu) Then
            count = count + 1
            Mid(result, count, 1) = kytu
            dic.Add kytu, ""
        End If
    Next k
    batman1 = Left(result, count)
    Set dic = Nothing
End Function
 
Upvote 0
Cùi bắp lót gạch
Mã:
Sub Test()
Dim Str_
Dim i, j, k, Tm
Dim Res
Tm = Timer
Str_ = Sheet1.Range("A1")
ReDim Res(65535)
For i = 1 To 65535
    j = ChrW(i)
    k = InStr(Str_, j)
    If k Then Res(k) = j
Next i
j = ""
For i = 0 To 65535
    If Res(i) <> "" Then
        j = j & Res(i)
    End If
Next i
With Sheet2
    .UsedRange.Clear
    .Range("A3") = j
    .Range("A1") = Timer - Tm
End With
End Sub
 
Upvote 0
Bài viết này dành cho các bạn đang học hoặc đam mê hoặc đang phát triển ứng Excel với VBA.
Nhằm luyện tập, học hỏi và phát triển thêm kỹ năng viết Code VBA với những bài tập đơn giản.

"Lọc ký tự trùng nhau trong chuỗi".
--------------------------------
Bài tập: Viết một hàm lọc chuỗi bất kỳ loại bỏ các ký tự trùng nhau trả về kết quả là một chuỗi chứa các ký tự duy nhất, phân biệt ký tự hoa thường và không phân biệt ký tự hoa thường. Và hãy tối ưu hàm một cách tốt nhất có thể.

Ví dụ:

1. "abcde" => "abcde"
2. "tương tư có tương tự suy tư" => ""tương cóựsuy"
3. "Bài hát: Thanh Xuân Của Tôi (Viral Clip) Ca sĩ: Đan Trường Nhạc Hoa, Lời Việt: Tăng Nhật Tuệ Camera: Kuke Hà - Ngọc Kim Lời bài hát: Cùng nhau ngắm mưa Đoạn đường đón đưa Cười cười nói nói vui như thế Thanh xuân lấp lánh như bụi mưa Cùng nhau đếm sao Một thời huyên náo Giật mình nhìn thời gian đã xoá Thanh xuân như chút gió ngọt ngào Ta đã gặp nhau để nói thương nhau Giữ cho nhau ký ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Tự do hát ca Bụi đường quê nhà Nghiêng nghiêng cánh chim bay trong gió Mưa bay lấp lánh những ngày xanh Thành đô nắng hoa Lòng người băng giá Nhiều lần giật mình trong nước mắt Thanh xuân hôm qua đã nhạt nhoà Ta đã gặp nhau để nói thương nhau Giữ cho nhau kí ức nhiệm màu Nước mắt có lần ướt khoé mi Cũng chẳng muốn rời tay người Tay cầm tay để nói thương nhau Dẫu mai sau vật đổi sao dời Thương vẫn thương vậy thôi Đừng quên nhé thanh xuân của tôi Thương vẫn thương vậy thôi Vì em đó thanh xuân của tôi."​
=> "Bài hát:TanXuâCủô(Vrlp)sĩĐườgNạcHo,LệăậmeKk-ọbùắđóvếxấụMộyêGìãúặểơữýứớầéũẳốDẫổdừqựòềí."​
=> "Bài hát:anXuâCủô(Vrlp)sĩĐườgạo,ệăậmeK-ọùắóếấụộyêìãúặểơữýứớầéũẳốDẫổừqựòềí." (Không phân biệt hoa thường)​

Yêu cầu:
1. Cú pháp phải tối ưu.
2. Bài giải có thể nhiều hàm Sử dụng hàm thuần VBA hoặc thư viện Regular Expressions hoặc một thư viện nào có thể
3. Ưu tiên tốc độ xử lý.

(có hoặc không có giải thích về thuật toán hoặc giải thuật đã sử dụng)



Ứng dụng của hàm: Nhận biết và đếm số ký tự đã sử dụng trong một bài thơ, bài viết, ...
--------------------------------
Mời các bạn tham gia!
Thấy đông vui, cũng ráng góp code
Mã:
Function ABC(ByVal iText As String, Optional TextCompare As Boolean = False) As String
  'Mac dinh TextCompare= False: Phan biet ky tu Hoa va Thuong
  'TextCompare= True: Khong Phan biet ky tu Hoa va Thuong
  If Len(iText) = 0 Then Exit Function
  Dim j&, k&, sCol&, iChr$, tmp$
  If TextCompare = False Then bl = 0 Else bl = 1 
  sCol = Len(iText)
  k = 1
  tmp = Mid(iText, 1, 1)
  For j = 2 To sCol
    iChr = Mid(iText, j, 1)
    If InStr(1, tmp, iChr, bl) = 0 Then
      k = k + 1
      Mid(iText, k, 1) = iChr
      tmp = Mid(iText, 1, k)
    End If
  Next j
  ABC = Mid(iText, 1, k)
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Cùi bắp lót gạch
Mã:
...
ReDim Res(65535)
For i = 1 To 65535
    j = ChrW(i)
    k = InStr(Str_, j)
    If k Then Res(k) = j
Next i
j = ""
For i = 0 To 65535
    If Res(i) <> "" Then
        j = j & Res(i)
    End If
Next i
Code của rất kém hiệu quả về năng lượng.
Search: Số ký tự sử dụng trong chuỗi chỉ có khoảng hơn trăm nhưng code sẽ phải search chuỗi hơn 60 ngàn lần.
Ghép: nếu có 100 ký tự thì code phải ghép 100 lần.
Chú thích: nếu máy có cache tốt thì dùng mảng để search là điều đúng. Nhưng bạn làm ngược. Đáng lẽ dùng ký tự lấy ra từ chuỗi và search mảng theo chỉ số thì nhanh hơn nhiều.
Tóm lại thì bài này mang tiếng "đơn giản" nhưng thực tế vì những điều kiện nó đưa ra khiến nó trở thành sân chơi của dân xịn. Và tôi không tin là ở đây người ta chịu khó giải thích những điểm yếu của dân mới vào nghề đâu.
Những code xịn mà ngừoi ta đăng lên sẽ là thành quả của kinh nghiệm nhiều năm. Những người mới vào nghề xem để mà biết chứ không học được gì đâu. Muốn học các giải thuật chiến, bạn không thể học "người ta làm như thế nào"; mà phải học "tại sao người ta làm thế"
Nếu là bài học thực sự thì điều kiện của nó phải có phần giải thích "sau khi thực hiện điều a, b, c,... thì bạn đã học được gì"

Thấy mọi người gửi bài mà mình hoang mang quá. :D Thôi thì cũng rụt rè dự thi.

Mã:
Function batman1(ByVal text As String) As String
Dim k As Long, count As Long, kytu As String, result As String, dic As Object
    If Len(text) = 0 Then Exit Function
    result = String(Len(text), Chr(0))
    kytu = String(1, Chr(0))
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare ' khong phan biet hoa thuong
    For k = 1 To Len(text)
        Mid(kytu, 1, 1) = Mid(text, k, 1)
        If Not dic.Exists(kytu) Then
            count = count + 1
            Mid(result, count, 1) = kytu
            dic.Add kytu, ""
        End If
    Next k
    batman1 = Left(result, count)
    Set dic = Nothing
End Function
Về giải thuật không kể, nhưng về "sử dụng hàm thư viện" thì Bác có 95% khả năng thua tôi rồi.
Nếu tôi copy code của Bác, và nghe theo lời của anh chàng "viết lại hàm Microsoft" kia. Tôi dùng các hàm thời thượng (Q)BASIC thì cứ mỗi lượt gọi hàm string, tôi nhanh hơn bác vài na-nô giây. :p:p:p
 
Upvote 0
Hưởng ứng phong trào góp vui
 

File đính kèm

  • GopVui.rar
    2.6 MB · Đọc: 44
Upvote 0
Cùi bắp xếp gạch mà bác.
Bạn cũng chả học được gì cả, bởi vì như tôi đã nói, "đây là sân chơi của dân xịn":

... Và tôi không tin là ở đây người ta chịu khó giải thích những điểm yếu của dân mới vào nghề đâu...
Người ta để giành năng lượng để chiến đấu, suy diễn những giải thuật ngặt nghèo.
 
Upvote 0
Web KT
Back
Top Bottom