Cần giúp đỡ về việc ghép các chuôi kí tự giống nhau thành 1 chuỗi trong Excel

[clean190914]

Xin chào mọi người !

Mình đang cần giúp đỡ về cách ghép các chuôi kí tự giống nhau ở cùng một cột thành 1 chuỗi trong Excel .
Cột A là các chuỗi cần ghép và cột B là kết quả sau khi ghép xong, excel sẽ rà trong cột A xem có ô nào chứa tất cả ký tự trong cột A thì sẽ xuất ra. Mình phải sử dụng hàm nào hay cách gì để ghép các kết quả ở cột A ra như cột B . Bạn nào biết thì giúp mình với.
Mình xin cám ơn

VD :

Cột A

Cột B

Kỹ năng giao tiếp
<div><table><tr valign="top"><td> ==>

</td>
Các khóa học kỹ năng giao tiếp ứng xử
</tr>
Các kỹ năng giao tiếp

Kỹ năng

Các khóa học kỹ năng giao tiếp ứng xử

Kỹ năng ứng xử

</table></div>

View more random threads:

• Biểu đồ tương quan nhiệt mưa
• muốn lấy giá trị max trong 1 cột phải thỏa điều kiện trong 3 cột khác
• Chuyển đổi về dạng number
• Cách sắp xếp theo AnphaB có merge
• Bị lỗi chữ Đ đứng trước chữ D khi Sort ABC trong excel 2010
• Cần giúp đỡ về việc ghép các chuôi kí tự giống nhau thành 1 chuỗi trong Excel
• Code để exit và save 1 file excel đang mở
• cách download dữ liệu trong VBA
• Tính tổng dữ liệu của cột
• Giúp về Hàm thời gian trong Excel

[ichiase24h]

Xin chào mọi người !

Mình đang cần giúp đỡ về cách ghép các chuôi kí tự giống nhau ở cùng một cột thành 1 chuỗi trong Excel .

Thử hàm tự tạo này xem sao
Cú pháp: =Tim( Vùng dữ liệu )

Public Function Tim(DL As Range) As String
Dim Tam, Mau As Range, i As Long

With CreateObject("scripting.dictionary")
For Each Mau In DL
Tam = Split(Mau, " ")
For i = 0 To UBound(Tam)
If Not .exists(UCase(Tam(i))) Then
.Add UCase(Tam(i)), ""
End If
Next i
Next Mau

For Each Mau In DL
If Len(Mau) = Len(Join(.keys, " ")) Then
Tam = Split(Mau, " ")
For i = 0 To UBound(Tam)
If .exists(UCase(Tam(i))) Then
Tim = Tim & " " & Tam(i)
End If
Next i
If Len(Trim(Tim)) = Len(Mau) Then Tim = Trim(Tim): Exit For
End If
Next Mau

End With
End Function

[nguyennam19]

[IMG]images/smilies/a41.gif[/IMG] Cám ơn anh nhiều lắm ạ. Nhờ anh mà em tiết kiệm được 1 đống thời gian làm việc đó ạ . Cám ơn anh nhiều [IMG]images/smilies/a44.gif[/IMG][IMG]images/smilies/a44.gif[/IMG][IMG]images/smilies/a44.gif[/IMG]

[angelareview]

Cám ơn anh Gtri

Nhưng trường hợp này thì nó lại không ra kết quả ( anh xem file đính kèm ) , anh có thể giúp em được không. Cám ơn anh nhiều [IMG]images/smilies/a44.gif[/IMG]

[hocon84]

Cám ơn anh Gtri

Nhưng trường hợp này thì nó lại không ra kết quả ( anh xem file đính kèm ) , anh có thể giúp em được không. Cám ơn anh nhiều [IMG]images/smilies/a44.gif[/IMG]

[huutrangqb]

Cám ơn anh Gtri

Nhưng trường hợp này thì nó lại không ra kết quả ( anh xem file đính kèm ) , anh có thể giúp em được không. Cám ơn anh nhiều [IMG]images/smilies/a44.gif[/IMG]

Có lẽ với nguồn dữ liệu lớn thì kết quả chỉ là gần đúng
Xem file đính kèm, nhấn "lọc gần đúng"
Dữ liệu tại cột A, kết quả dán vào cột D

Public Sub Tim_Cau_Hoan_Chinh()
Dim DL, Tam, kq(), r As Long, rw As Long, c As Long

DL = Sheet1.Range("A1").CurrentRegion

For r = 1 To UBound(DL)
Tam = Split(DL(r, 1), " ")
For rw = 1 To UBound(DL)
If rw <> r Then
For c = 0 To UBound(Tam)
If InStr(UCase(DL(rw, 1)), UCase(Tam(c))) Then
Tam(c) = ""
End If
Next c
If Len(Application.Trim(Join(Tam))) = 0 Then DL(r, 1) = ""
End If
Next rw
Next r
ReDim kq(1 To UBound(DL), 1 To 1)

rw = 0
For r = 1 To UBound(DL)
If DL(r, 1) <> "" Then
rw = rw + 1
kq(rw, 1) = DL(r, 1)
End If
Next r

Sheet1.Range("D1", Sheet1.Range("D65000").End(xlUp)).Clear
Sheet1.Range("D1").Resize(rw, 1).Value = kq
End Sub

[kenshin]

[QUOTE="gtri"]ok.
code bị lỗi 2 chỗ

Public Sub Tim_Cau_Hoan_Chinh()
Dim DL, Tam, kq(), r As Long, rw As Long, c As Long

DL = Sheet1.Range("A1").CurrentRegion

For r = 1 To UBound(DL)
For rw = 1 To UBound(DL)
Tam = Split(DL(r, 1), " ")  '<--chuyển vào vòng lặp này
If rw <> r Then
For c = 0 To UBound(Tam)
If InStr(" " & UCase(DL(rw, 1)) & " ", " " & UCase(Tam(c)) & " ") Then  'Thêm chặn chuỗi
Tam(c) = ""
End If
Next c
If Len(Application.Trim(Join(Tam))) = 0 Then DL(r, 1) = ""
End If
Next rw
Next r
ReDim kq(1 To UBound(DL), 1 To 1)

rw = 0
For r = 1 To UBound(DL)
If DL(r, 1) <> "" Then
rw = rw + 1
kq(rw, 1) = DL(r, 1)
End If
Next r
Sheet1.Range("D1", Sheet1.Range("D65000").End(xlUp)).Clear
Sheet1.Range("D1").Resize(rw, 1).Value = kq
End Sub

---
Vẫn chưa xử lý chuỗi rỗng nên dữ liệu lớn chắc là sẽ chậm</div>

</div>
</div>
</div>
Bạn cứ thử tính số vòng lặp mà mỗi code phải duyệt qua xem có khác biệt gì lớn không. Cụ thể hơn, bạn thử test 2 code với cùng một dữ liệu lớn rồi so sánh tốc độ xem.

[Hardion]

Bạn cứ thử tính số vòng lặp mà mỗi code phải duyệt qua xem có khác biệt gì lớn không. Cụ thể hơn, bạn thử test 2 code với cùng một dữ liệu lớn rồi so sánh tốc độ xem.

Có lẽ là vấn đề trao đổi là về thuật toán.
Việc hiệu chỉnh để đạt tốc độ đâu có gì khó khăn.

[hongson1992]

Có lẽ là vấn đề trao đổi là về thuật toán.
Việc hiệu chỉnh để đạt tốc độ đâu có gì khó khăn.

Tôi thì lại nghĩ thuật toán là nhân tố chính quyết định tốc độ. Nếu không, theo bạn thuật toán tốt hay không tốt người ta đánh giá trên góc độ nào?
Với thuật toán như cũ của bạn, bạn thử hiệu chỉnh xem tốc độ được cải thiện bao nhiêu.

[phuonglinh]

Tôi thì lại nghĩ thuật toán là nhân tố chính quyết định tốc độ. Nếu không, theo bạn thuật toán tốt hay không tốt người ta đánh giá trên góc độ nào?
Với thuật toán như cũ của bạn, bạn thử hiệu chỉnh xem tốc độ được cải thiện bao nhiêu.

Vẫn dùng cách loại trừ chuỗi ngắn.
Viết lại code

Public Sub Tim_Cau_Hoan_Chinh()
Dim DL, kq(), r As Long, rw As Long, Tg
Static dic As Scripting.Dictionary, reg As RegExp
Set dic = New Scripting.Dictionary
Set reg = New RegExp

Tg = Timer
DL = Sheet1.Range("A1").CurrentRegion
For r = 1 To UBound(DL)
DL(r, 1) = UCase(DL(r, 1) & " ")
If Not dic.Exists(DL(r, 1)) Then dic.Add DL(r, 1), ""
Next r
kq = dic.Keys

For r = 1 To UBound(DL)
reg.Pattern = Replace(DL(r, 1), " ", " .*")
For rw = 0 To UBound(kq)
If DL(r, 1) <> kq(rw) Then
If reg.Test(kq(rw)) Then
dic.Remove DL(r, 1)
Exit For
End If
End If
Next rw
kq = dic.Keys
Next r

With Sheet1
.Range("B1") = Timer - Tg
.Range("D1:D65000").Clear
.Range("D1").Resize(dic.Count, 1).Value = Application.Transpose(kq)
End With

Set dic = Nothing
Set reg = Nothing
End Sub

-----
chọn ms scripting runtime, ms vbscript regular exp trong tool references