Nối Chuỗi có điều kiện trong excel (1 người xem)

[huele289]

Chào các bác
E có 1 file cần nối chuỗi theo file đính kèm
e muốn nối chuỗi theo điều kiện sau, những ID nào giống nhau sẽ nối chuỗi cột đó là
VD: ID 23567 - ToA-cột nối (ToA,ToB,ToC)
23567 - ToB-cột nối (ToA,ToB,ToC)
23567 - ToC-cột nối (ToA,ToB,ToC)
Các bác nào có cao kiến xin chỉ giáo cho e ạ
Thank các bác nhiều

 

[ndu96081631]

Chào các bác
E có 1 file cần nối chuỗi theo file đính kèm
e muốn nối chuỗi theo điều kiện sau, những ID nào giống nhau sẽ nối chuỗi cột đó là
VD: ID 23567 - ToA-cột nối (ToA,ToB,ToC)
23567 - ToB-cột nối (ToA,ToB,ToC)
23567 - ToC-cột nối (ToA,ToB,ToC)
Các bác nào có cao kiến xin chỉ giáo cho e ạ
Thank các bác nhiều

Ghi kết quả vào cột bên cạnh xem nào. Mô tả chẳng hiểu mô tê gì ráo

 

[huele289]

E gửi lại 1 ví dụ minh hoạ, kèm file lại
Nhờ a chỉ giáo dùm e nhé


Thanks!

 

[be_09]

E gửi lại 1 ví dụ minh hoạ, kèm file lại
Nhờ a chỉ giáo dùm e nhé

View attachment 196531
Cảm ơn!

Copy sheet2 qua sheet1 rồi thử xem kết quả (nó gộp Cell giống nhau vào 1 dòng) và xóa dòng thừa.

 

[befaint]

1 ví dụ minh hoạ

---- (Tự xóa).

 

[ndu96081631]

E gửi lại 1 ví dụ minh hoạ, kèm file lại
Nhờ a chỉ giáo dùm e nhé

View attachment 196531
Cảm ơn!

Cho bạn 2 lựa chọn:
1> Code 1 chỉ nối chuỗi, không lọc duy nhất:

Sub CombineText1()
  Dim aSource
  Dim sKey, sItem As String
  Dim dic As Object
  Dim lR As Long, idx As Long
  aSource = Sheet1.Range("A8:B30000").Value
  Set dic = CreateObject("Scripting.Dictionary")
  ReDim aDes(1 To UBound(aSource, 1), 1 To 1)
  For lR = 1 To UBound(aSource, 1)
    sKey = aSource(lR, 1)
    If sKey <> Empty Then
      sItem = aSource(lR, 2)
      If Not dic.Exists(sKey) Then
        dic.Add sKey, sItem
      Else
        dic.item(sKey) = dic.item(sKey) & ", " & sItem
      End If
    End If
  Next
  For lR = 1 To UBound(aSource, 1)
    sKey = aSource(lR, 1)
    If sKey <> Empty Then aDes(lR, 1) = dic.item(sKey)
  Next
  Sheet1.Range("C8").Resize(lR - 1).Value = aDes
End Sub

2> Code 2 vừa nối chuỗi vừa lọc duy nhất sang khu vực khác:

Sub CombineText2()
  Dim aSource
  Dim sKey, sItem As String
  Dim dic As Object
  Dim lR As Long, idx As Long
  aSource = Sheet1.Range("A8:B30000").Value
  Set dic = CreateObject("Scripting.Dictionary")
  ReDim aDes(1 To UBound(aSource, 1), 1 To 2)
  For lR = 1 To UBound(aSource, 1)
    sKey = aSource(lR, 1)
    If sKey <> Empty Then
      sItem = aSource(lR, 2)
      If Not dic.Exists(sKey) Then
        idx = idx + 1
        dic.Add sKey, idx
        aDes(idx, 1) = sKey
        aDes(idx, 2) = sItem
      Else
        aDes(dic.item(sKey), 2) = aDes(dic.item(sKey), 2) & ", " & sItem
      End If
    End If
  Next
  If idx Then Sheet1.Range("F8:G8").Resize(idx).Value = aDes
End Sub

theo tôi thì code 2 hợp lý hơn, vì chẳng lý nào cùng 1 ID mà cứ liệt kê ra hết

 

[huele289]

Anh có cách nào để tạo 1 hàm excel ko ạ, vì e copy đoạn code vào VBA thì nó ko thực hiện đuợc lệnh, e phải kích run để chạy
bác có cao kiến nào chỉ e với
Thank bác nhiều

 

[ndu96081631]

Anh có cách nào để tạo 1 hàm excel ko ạ, vì e copy đoạn code vào VBA thì nó ko thực hiện đuợc lệnh, e phải kích run để chạy
bác có cao kiến nào chỉ e với
Thank bác nhiều

Hàm đương nhiên là viết được nhưng với dữ liệu 20000 dòng của bạn thì chắc chắn sẽ lết bánh