Lấy những tên xuất hiện > 3 lần trong 1 ô (1 người xem)
- Thread starter redosolo
- Ngày gửi
Người dùng đang xem chủ đề này
Let'GâuGâu
Thành viên mới
- Tham gia
- 12/9/13
- Bài viết
- 3,131
- Được thích
- 2,732
cái này chắc fải xài vba quá, bạn muốn thử ko?
Kết quả bạn ghi trong sheet không đúng với yêu cầu. Yêu cầu là lấy ra những mục lặp lại hơn 3 lần (> 3). Tôi không nghĩ là bạn gõ nhầm vì có tới 3 chỗ (2 chỗ trên GPE và 1 chỗ trong sheet)
Cố gắng viết chính xác nhé bạn.
Tôi chỉ nhắc bạn thôi chứ ý của bạn thì tôi cũng đoán được. Vì trong trường hợp khác có thể sẽ không ai đoán được. Tôi nhắc để tạo thói quen
----------
Có nhiều cách. Thậm chí có thể dùng vòng FOR. Nhưng FOR là cơm bữa, ta dùng phở nhé.
Công thức cho E9
Mã:
Repeat3(E6)
hoặc
RepeatN(E6, 3)Với RepeatN có thể thiết lập số lần lặp. Vd. ở ô E9 ta có =RepeatN(E6, 3) thì kết quả là "sơn, hải" nhưng ở E10 lại có =RepeatN(E6;2) thì kết quả là "sơn, hải, lâm"
------------
Code phục vụ trường hợp có "mục" rỗng vd. "sơn, tè, hải, sơn, lâm, , sơn, hải, hải, lâm, đô, "
Code viết và mới test 3 lần. Bạn phải tự kiểm tra
Alt + F11 --> Insert --> Module --> dán code sau vào Module1
Mã:
Function Repeat3(ByVal cell_str As String) As String
Dim Arr() As String, dic As Object, s As String, index As Long, tmp
Arr = Split(cell_str, ",")
Set dic = CreateObject("Scripting.Dictionary")
For index = 0 To UBound(Arr)
s = Trim(Arr(index))
If Not dic.exists(s) Then
dic.Add s, index * 1000 + 1
Else
dic.Item(s) = dic.Item(s) + 1
End If
Next index
s = ""
For Each tmp In dic.items
If tmp Mod 1000 >= 3 Then s = s & Arr(tmp \ 1000) & ", "
Next tmp
Set dic = Nothing
Repeat3 = Left(s, Len(s) - 2)
End Function
Function RepeatN(ByVal cell_str As String, ByVal repeat_count As Long) As String
Dim Arr() As String, dic As Object, s As String, index As Long, tmp
Arr = Split(cell_str, ",")
Set dic = CreateObject("Scripting.Dictionary")
For index = 0 To UBound(Arr)
s = Trim(Arr(index))
If s <> "" Then
If Not dic.exists(s) Then
dic.Add s, index * 1000 + 1
Else
dic.Item(s) = dic.Item(s) + 1
End If
End If
Next index
s = ""
For Each tmp In dic.items
If tmp Mod 1000 >= repeat_count Then s = s & Arr(tmp \ 1000) & ", "
Next tmp
Set dic = Nothing
RepeatN = Left(s, Len(s) - 2)
End FunctionLet'GâuGâu
Thành viên mới
- Tham gia
- 12/9/13
- Bài viết
- 3,131
- Được thích
- 2,732
góp thêm một đoạn code nhỏ
Mã:
Function DemTen(rng As Range, n As Byte)
Dim ch As String, tam(), kq(), d As Object
ch = rng.Value
ReDim tam(1 To Len(ch), 1 To 2)
Set d = CreateObject("Scripting.Dictionary")
pos = 1
For i = 1 To Len(ch)
If Mid(ch, i, 1) = "," Then
npos = i
If Not d.Exists(Trim(Replace(Mid(ch, pos, npos - pos), ",", " "))) Then
k = k + 1
d.Add Trim(Replace(Mid(ch, pos, npos - pos), ",", " ")), k
tam(k, 1) = Trim(Replace(Mid(ch, pos, npos - pos), ",", " "))
tam(k, 2) = 1
Else
tam(d.Item(Trim(Replace(Mid(ch, pos, npos - pos), ",", " "))), 2) = tam(d.Item(Trim(Replace(Mid(ch, pos, npos - pos), ",", " "))), 2) + 1
End If
pos = npos + 1
End If
Next i
For i = 1 To UBound(tam)
If tam(i, 2) >= n Then
l = l + 1
ReDim Preserve kq(1 To l)
kq(l) = tam(i, 1)
End If
Next i
DemTen = Join(kq, ",")
Set d = Nothing
End Functioncthuc
Mã:
=DemTen(E6,3)Mì xào dòn tuy không dân tộc tính bằng phở, nhưng có thể dùng để đổi vị
Mã:
Function DupList(ByVal cllStr As String, ByVal dupNumAs Integer) As String
[COLOR=#008000]' hàm tìm những chuỗi trong ô được lặp lại dupNum lần hoặc nhiều hơn
' thay vì dùng phương pháp hữu hiệu nhất là dictionary thì hàm này chơi kiểu bằng cách dùng mảng
[/COLOR]Dim s As Variant, s1 As Variant
Dim cnt As Integer
Dim aL As Object
Set aL = CreateObject("System.Collections.ArrayList") [COLOR=#008000]' lười biếng viết hàm sort nên dùng collection[/COLOR]
For Each s In Split(cllStr, ",")
If s <> "" Then aL.Add Trim(s)
Next s
aL.Sort
[COLOR=#008000]' sau khi có mảng đã sắp xếp, chỉ việc đếm
[/COLOR]cnt = 0
s1 = ChrW(32768) [COLOR=#008000]' trị gì cũng được, miễn là không thể tìm thấy trong chuõi[/COLOR]
For Each s In aL
If s <> s1 Then
If cnt >= dupNum Then DupList = DupList & ", " & s1
s1 = s
cnt = 1
Else
cnt = cnt + 1
End If
Next s
DupList = Mid(DupList, 3, Len(DupList))
End Function
Lần chỉnh sửa cuối:
- Tham gia
- 14/7/14
- Bài viết
- 14
- Được thích
- 10
mình sức khoẻ yếu nên chỉ viết được có 1 vòng lặp, bạn thử coi chạy có nổi không ?
Mã:
Function loc(cell, n)
Set d = CreateObject("scripting.dictionary")
For Each e In Split(Replace(cell, " ", ""), ",")
If e <> "" And Not d.exists(e) Then If (Len(cell) _
- Len(Replace(cell, e, ""))) / Len(e) >= n Then d.Add e, ""
Next
loc = Join(d.keys, ", ")
End FunctionNhớ lời của danh nhân "viết hàm kiểu đó người ta tưởng thiệt mà áp dụng lung tung thì nguy quá", tôi giải thích lời của tôi trong các bài #9 và #10 như sau:
#9:
Kỹ thuật dùng hàm Replace để đếm ký tự là một kỹ thuật được ưa chuộng vì tính cách gọn gàng của nó. Người ta sẵn sàng hy sinh sức máy để đổi lại số code ngắn. Tuy nhiên khi nới rộng kỹ thuật này để đếm "cụm từ" (*) thay vì ký tự thì hiệu quả càng giảm sút.; và code cũng tăng phần rắc rối.
Dân làm việc với chuỗi đều biết hàm Replace không thể thay thế từ (*) một cách đơn giản như vậy được. Nếu từ này chứa từ kia thì hàm này không phân biệt được.
Ví dụ "Tư" chứa trong "Tươi", "Tương", "Tường", "Tưởng".
Khi dùng hàm này, người ta bọc từ giữa hai ký tự ngăn chuỗi. Ví dụ "|Tư|"
#10:
Khi đã dùng hàm Replace để xoá từ thì đâu cần phải dùng Dic để lọc duy nhất nữa!
Xoá xong rồi, lần tới đâu gặp lại mà sợ! Đồng thời nếu biết dùng chuỗi đã thâu gọn còn được lợi điểm ở chỗ chuỗi càng lúc càng ngắn, đỡ tốn sức máy.
vd. Chuỗi "a,b,a,c,a,b,e,f";
xoá "a", còn lại ",b,,c,,b,e,f";
ghi được "a" (có tất cả 3 a);
lần xét "a" tới (sau "b") thì chỉ tìm trên chuỗi ",,,c,,e,f" đâu còn "a" nữa mà sợ bị lặp lại.
(*) chú thích: bên trên tôi dùng phân biệt "cụm từ" và "từ", bởi vì giải thuật của bài #8 đã giản dị code bằng cách ngang nhiên xoá hết các dấu cách trong chuỗi; tức là tất cả các "cụm từ" đều trở thành "từ".
ví dụ: "Lan Anh, Lê, Kim, Lan Anh, Lan Anh, Hồng" sẽ không cho ra kết quả "Lan Anh" !!! (mà cũng chẳng cho ra "LanAnh" luôn)
#9:
Kỹ thuật dùng hàm Replace để đếm ký tự là một kỹ thuật được ưa chuộng vì tính cách gọn gàng của nó. Người ta sẵn sàng hy sinh sức máy để đổi lại số code ngắn. Tuy nhiên khi nới rộng kỹ thuật này để đếm "cụm từ" (*) thay vì ký tự thì hiệu quả càng giảm sút.; và code cũng tăng phần rắc rối.
Dân làm việc với chuỗi đều biết hàm Replace không thể thay thế từ (*) một cách đơn giản như vậy được. Nếu từ này chứa từ kia thì hàm này không phân biệt được.
Ví dụ "Tư" chứa trong "Tươi", "Tương", "Tường", "Tưởng".
Khi dùng hàm này, người ta bọc từ giữa hai ký tự ngăn chuỗi. Ví dụ "|Tư|"
#10:
Khi đã dùng hàm Replace để xoá từ thì đâu cần phải dùng Dic để lọc duy nhất nữa!
Xoá xong rồi, lần tới đâu gặp lại mà sợ! Đồng thời nếu biết dùng chuỗi đã thâu gọn còn được lợi điểm ở chỗ chuỗi càng lúc càng ngắn, đỡ tốn sức máy.
vd. Chuỗi "a,b,a,c,a,b,e,f";
xoá "a", còn lại ",b,,c,,b,e,f";
ghi được "a" (có tất cả 3 a);
lần xét "a" tới (sau "b") thì chỉ tìm trên chuỗi ",,,c,,e,f" đâu còn "a" nữa mà sợ bị lặp lại.
(*) chú thích: bên trên tôi dùng phân biệt "cụm từ" và "từ", bởi vì giải thuật của bài #8 đã giản dị code bằng cách ngang nhiên xoá hết các dấu cách trong chuỗi; tức là tất cả các "cụm từ" đều trở thành "từ".
ví dụ: "Lan Anh, Lê, Kim, Lan Anh, Lan Anh, Hồng" sẽ không cho ra kết quả "Lan Anh" !!! (mà cũng chẳng cho ra "LanAnh" luôn)
concogia
Gội rồi mới Cạo
- Tham gia
- 17/9/09
- Bài viết
- 3,412
- Được thích
- 6,881
Mình nghĩ bài này dùng Replace cũng hay, nhưng Replace & InStr cũng dễ bị "tèo" lắm, có nhiều cách viết, không biết code này có vướng chỗ nào hông nữa:
Mã:
Public Function Trung(Cll, iSo) As String
Dim A, B, C, Tam, Kq
Cll = Replace(Replace(Cll, " ", ""), ",", "@") & "@"
A = Len(Cll)
Do While A > 0
B = InStr(Cll, "@")
Tam = Left(Cll, B - 1)
Cll = Replace(Cll, Left(Cll, B), "")
C = Len(Cll)
If (A - C) / B >= iSo Then Kq = Kq & ", " & Tam
A = C
Loop
If Len(Kq) Then Trung = Right(Kq, Len(Kq) - 2)
End FunctionHíc
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,963
Nếu vẫn dùng Dictionary và 1 VÒNG LẬP thì.. sao ta? (không dùng Replace hay InStr)
Em "cảm giác" rằng dùng 1 VÒNG LẬP vẫn ra nhưng... lười
Ẹc... Ẹc...
Quang_Hải
Thành viên gạo cội
- Tham gia
- 21/2/09
- Bài viết
- 6,073
- Được thích
- 8,004
- Nghề nghiệp
- Làm đủ thứ
Bác Bill cho sẵn cái Dic rồi mà không dùng thì cũng phí
Em tạm code thế này, mặc định là các tên cách nhau bởi dấu phẩy. Nếu có thêm gì khác thì chỉnh lại xíu
Chắc là thêm cái Replace ngay lúc Split
PHP:
Function Loc(cell As Range, MX As Byte)
Dim tmp, i, StrRes
tmp = Split(cell, ",")
With CreateObject("scripting.dictionary")
For i = LBound(tmp) To UBound(tmp)
If Not .exists(Trim(tmp(i))) Then
.Add Trim(tmp(i)), 1
Else
.Item(Trim(tmp(i))) = .Item(Trim(tmp(i))) + 1
If .Item(Trim(tmp(i))) = MX Then
StrRes = StrRes & Trim(tmp(i)) & ","
End If
End If
Next
End With
If Len(StrRes) Then
Loc = Left(StrRes, Len(StrRes) - 1)
Else
Loc = ""
End If
End Functionconcogia
Gội rồi mới Cạo
- Tham gia
- 17/9/09
- Bài viết
- 3,412
- Được thích
- 6,881
Thì "Dictionary và 1 VÒNG LẬP" ra ......là cái chắc rồi. Tách nó ra, cho chạy từ đầu tới cuối, dùng em "Đít- to" đếm nó, "thằng" nào bằng điều kiện thì gán vào kết quả, nhưng "chơi" kiểu này phải......chạy hết
Híc
Huhu, chưa chi chú Hải đã làm rồi, chán thật, hông chơi nữa, đi ngủ đây
Lần chỉnh sửa cuối:
Có ai nói không nên dùng Dic đâu. Ở đây nói chuyện "mì xào dòn", "cơm tấm",... Chủ ý đưa ra 2 giải thuật khác: cách đếm mảng đã sắp xếp (căn bản lớp vỡ lòng nhưng code dài dòng); và loại [cụm] từ bằng replace (code ngắn nhưng rất dễ sai)
Code này vẫn dùng kiểu đổi " " thành "" cho nên "Lan Anh" cho ra kết quả là "LanAnh"
Trước đó tôi đã có ý định dùng phương "đêm bằng cách loại trừ" (hàm replace + len) nhưng bị vướng cái chỗ "Trim". Chưa biết cách nào trim được cụm từ mà không qua vòng lặp cho nên thôi.
Nếu ta chấp nhận "chuẩn hoá" chuỗi - tức là tóm tất cả các dấu cách liền nhau lại thành 1 thì có thể dùng hàm Application.Trim.
Cll = Replace(Replace(Application.Trim(Cll), " ,", ","), ",", "@") & "@" ' => loại các dấu cách trước dấu phẩy
Nếu theo quy ước những dấu cách giữa 2 từ trong 1 cụm từ phải giữ nguyên thì bắt buộc phải dùng vòng lặp để [VBA.]Trim từng cụm từ trước.
Mã:
Function RptLst(ByVal cllStr As String, ByVal rptNum As Integer) As String
[COLOR=#008000]' tìm trong chuõi những cụm từ được lặp lại ít nhất rptNum lần
' các cụm từ cách nhau bởi dấu phẩy. Hàm này cũng chuẩn hoá cụm từ kết quả (gom các dấu cách lại thành 1)
[/COLOR]Dim cllStrNu As String, s As Variant
[COLOR=#008000]' chuẩn hoá chuỗi, đồng thời nhét các dấu ngăn cụm từ vào
[/COLOR]cllStr = "|" & Replace(Replace(Replace( _
Application.Trim(cllStr), ", ", ","), " ,", ","), ",", "|,|") & "|"
RptLst = ""
For Each s In Split(cllStr, ",")
cllStrNu = Replace(cllStr, s, "")
If (Len(cllStr) - Len(cllStrNu)) >= Len(s) * rptNum Then _
RptLst = RptLst & IIf(RptLst = "", "", ", ") & s
cllStr = cllStrNu
Next s
RptLst = Replace(Replace(RptLst, ", ||", ""), "|", "")[COLOR=#008000] ' loại các dấu ngăn cụm từ[/COLOR]
End Function
[COLOR=#008000]' lưu ý là trong code trên, tôi cố tình đưa ra 2 kiểu mới:
' 1: so sánh số lần xuất hiện bằng cách nhân thay vì chia
' 2: dùng hàm IIF để xác định dấu phẩy khi ghép cụm từ[/COLOR]** Theo thiển ý thì có thiếu giống gì cách để giảm số vòng lặp. Vấn đề là có xứng đáng đặt tầm quan trọng như thế hay không.
concogia
Gội rồi mới Cạo
- Tham gia
- 17/9/09
- Bài viết
- 3,412
- Được thích
- 6,881
Trong đề bài không có "cụm từ" nên không quan tâm đến "cụm từ"
Nếu đã giải quyết được một từ thì cụm từ cũng thế thôi
Dùng App...Trim xóa những khoảng trắng vô nghĩa:
** Nếu dũ liệu nhập chuẩn, thay "dấu phân cách & khoảng trắng" bằng ký tự đặc biệt, thêm ký tự đặc biệt ở cuối, tiếp tục như với một từ
** Nếu dữ liệu nhập "xi- ma- chao" thì nên dùng Split cắt ra theo dấu phân cách, Trim tới Trim lui nó sạch sẽ, dùng em "Đít- to" đếm nó là "con gà đen" thôi
Híc
Lỡ bày trò ăn món lạ, phở, mì, cơm tấm xong rồi, chơi thử "cháo lòng" luôn:
Bài này dùng RegEx
Bài này dùng RegEx
Mã:
Function ttt(ByVal cllStr As String, ByVal rptNum As Integer) As String
[COLOR=#008000]' lưu ý là bài này dùng # làm ký tự ngăn chuỗi, bởi vì | có ý nghĩa đặc biệt trong RegEx
[/COLOR]Dim rx As Object, s As Variant
Set rx = CreateObject("VBScript.RegExp")
rx.IgnoreCase = False
rx.Global = True
rx.Pattern = " *# *"[COLOR=#008000] ' dấu ngăn cụm từ và tất cả các dấu cách chung quanh nó[/COLOR]
cllStr = rx.Replace("#" & Replace(cllStr, ",", "#,#") & "#", "#") [COLOR=#008000]' loại tất cả các dấu cách quanh dấu ngăn cụm từ[/COLOR]
For Each s In Split(cllStr, ",")
rx.Pattern = s
If rx.test(cllStr) Then
If rx.Execute(cllStr).Count >= rptNum Then ttt = ttt & ", " & s[COLOR=#008000] ' đạt số lần xuất hiện[/COLOR]
cllStr = rx.Replace(cllStr, "")[COLOR=#008000] ' xoá cụm từ này đi[/COLOR]
End If
Next s
rx.Pattern = "(^, )|(##, )|(, ##)|(#)"[COLOR=#008000] ' dấu ", " đầu chuỗi, hai dấu ## liên tiếp, và dấu # đơn độc[/COLOR]
ttt = rx.Replace(ttt, "")[COLOR=#008000] ' xoá hết các dấu trong mẫu[/COLOR]
End FunctionCháo lòng quá là ngon. Đập một quả trứng và cắt 2, 3 quẩy nữa thì tuyệt vời. Mà phở cũng ngon, mì xào dòn cũng tuyệt.
Cũng cháo lòng nhưng nấu hơi khác chút.
Mã:
Function RepeatN(ByVal cell_str As String, ByVal repeat_count As Long, _
Optional ByVal phan_biet_hoa_thuong As Boolean = False) As String
Dim re As Object, s As String, item
cell_str = Replace(cell_str, " ", "")
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.ignorecase = Not phan_biet_hoa_thuong
For Each item In Split(cell_str, ",")
If item <> "" Then
re.Pattern = "(?:^|,)" & item & "(?=(?:,|$))"
If re.Execute(cell_str).Count >= repeat_count Then
s = s & item & ", "
cell_str = re.Replace(cell_str, "")
End If
End If
Next item
Set re = Nothing
If s <> "" Then RepeatN = Left(s, Len(s) - 2)
End FunctionCám ơn cái ý kiến thêm chào quảy của bác. Tôi bị vướng ở chỗ cái khớp (match) nó xơi (consume) mất cái dấu phẩy trong mẫu (pattern) cho nên không giải quyết được trường hợp 2 từ giống nhau đi liền nhau, và bắt buộc phải dùng dấu ngăn chuỗi (#). Bây giờ thấy cái mẫu của bác mới nhớ ra là mình quên mất cái vụ "dòm trước ngó sau" (lookahead/lookaround)
tb. Code bác đã lỡ có cái "optional" rồi thì cũng nên cho thêm cái option "giữ nguyên cụm từ" hoăc "gọp lại thành 1 từ"
(phân biêt hoăc không Lan Anh với LanAnh)
(*) Giải thích thêm cho các bạn chưa quen với Regex:
Khi Regex tìm được một điểm khớp với mẫu, thì nó bắt đầu tìm tiếp kể từ SAU điểm khớp, cho nên nếu tìm mẫu ",b," (b giữa 2 dấu phẩy) trong chuỗi "a,b,b,c,..." thì nó chỉ tìm được cái đầu, cái kế nó không thấy vì nó đã vượt qua dấu phẩy (nó tìm tiếp kể từ ký tự b thứ 2, và không biết rằng b này cũng nằm giữa 2 dấu phẩy)
Kỹ thuật "dòm trước" giúp Regex giải quyết khó khăn này. Nếu tôi đặt dấu phẩy trong điều kiện "dòm trước" thì nó không thuộc về phần bị lướt qua sau điểm khớp. Nếu tìm mẫu ",b" + "dòm trước ," thì sau khi thấy ",b," nó lại bắt đầu tìm tiếp ở sau b và thấy được ",b," kế tiếp.
tb. Code bác đã lỡ có cái "optional" rồi thì cũng nên cho thêm cái option "giữ nguyên cụm từ" hoăc "gọp lại thành 1 từ"
(phân biêt hoăc không Lan Anh với LanAnh)
(*) Giải thích thêm cho các bạn chưa quen với Regex:
Khi Regex tìm được một điểm khớp với mẫu, thì nó bắt đầu tìm tiếp kể từ SAU điểm khớp, cho nên nếu tìm mẫu ",b," (b giữa 2 dấu phẩy) trong chuỗi "a,b,b,c,..." thì nó chỉ tìm được cái đầu, cái kế nó không thấy vì nó đã vượt qua dấu phẩy (nó tìm tiếp kể từ ký tự b thứ 2, và không biết rằng b này cũng nằm giữa 2 dấu phẩy)
Kỹ thuật "dòm trước" giúp Regex giải quyết khó khăn này. Nếu tôi đặt dấu phẩy trong điều kiện "dòm trước" thì nó không thuộc về phần bị lướt qua sau điểm khớp. Nếu tìm mẫu ",b" + "dòm trước ," thì sau khi thấy ",b," nó lại bắt đầu tìm tiếp ở sau b và thấy được ",b," kế tiếp.
Lần chỉnh sửa cuối:
Bài viết mới nhất
- Question
- Question
