Hỗ trợ tự động điền thông tin theo quy luật

[tangoctuan]

Chào các bác,

Nhờ các bác hỗ trợ giúp em có cách nào tự động giải quyết vấn đề trong file excel em gửi kèm với, hiện em đang phải làm bằng tay rất mệt .

Cám ơn các bác.

 

[HieuCD]

Chào các bác,

Nhờ các bác hỗ trợ giúp em có cách nào tự động giải quyết vấn đề trong file excel em gửi kèm với, hiện em đang phải làm bằng tay rất mệt .

Cám ơn các bác.

Tạo cột phụ D
D2 =", "&B2&IFERROR(LOOKUP(2,1/(A2=$A$1:A1),$D$11),"")
C2 =SUBSTITUTE(SUBSTITUTE(LOOKUP(2,1/($A$2:$A$12=A2),$D$2:$D$12),", "&B2,""),", ","",1)
Copy xuống

 

[tangoctuan]

Tạo cột phụ D
D2 =", "&B2&IFERROR(LOOKUP(2,1/(A2=$A$1:A1),$D$11),"")
C2 =SUBSTITUTE(SUBSTITUTE(LOOKUP(2,1/($A$2:$A$12=A2),$D$2:$D$12),", "&B2,""),", ","",1)
Copy xuống

Cám ơn bác nhiều. Nhưng bác có cách nào khác để chạy nhanh hơn được không? Vì em chạy dữ liệu hơn 100k dòng, treo máy luôn.

 

[HieuCD]

Cám ơn bác nhiều. Nhưng bác có cách nào khác để chạy nhanh hơn được không? Vì em chạy dữ liệu hơn 100k dòng, treo máy luôn.

Dùng Sub VBA

Sub QuocGiaKhac()
  Dim sArr(), Res() As String, iKey As String, tmp As String
  Dim i&, sRow&
  i = 1000000000
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 1)
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To sRow
      iKey = sArr(i, 1) & "#" & sArr(i, 2)
      If .exists(iKey) = False Then
        .Add iKey, ""
        .Item(sArr(i, 1)) = .Item(sArr(i, 1)) & ", " & sArr(i, 2)
      End If
    Next i
    For i = 1 To sRow
      tmp = Replace(.Item(sArr(i, 1)), ", " & sArr(i, 2), "")
      If Len(tmp) > 0 Then Res(i, 1) = Mid(tmp, 3, Len(tmp) - 2)
    Next i
  End With
  With Sheets("Sheet1")
    .Range("C2").Resize(sRow) = Res
  End With
End Sub