Gom các tài khoản trùng nhau. (1 người xem)

[nncb2008]

Chào các anh chị trên diễn đàn.
Có một nhu cầu muốn các anh chị trợ giúp được trình bày minh họa trong file đính kèm rất mong nhận được ý kiến từ các anh chị.
Xin trân trọng cảm ơn.

 

[giangleloi]

Chào các anh chị trên diễn đàn.
Có một nhu cầu muốn các anh chị trợ giúp được trình bày minh họa trong file đính kèm rất mong nhận được ý kiến từ các anh chị.
Xin trân trọng cảm ơn.

Nói chung là hên xui vì dữ liệu ít quá không lường trước được. Xem file, bấm nút và phản hồi lại nhé:

Sub GPE()
Dim Arr, vlArr(1 To 10000, 1 To 6), I, J, K, Dic, Tem
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
Arr = .Range(.[A4], .[A65000].End(3)).Resize(, 6).Value
For I = 1 To UBound(Arr, 1)
 Tem = Arr(I, 1) & "#" & Arr(I, 2)
  If Not Dic.exists(Tem) Then
    If K > 1 Then K = K - 1
      K = K + 1
      Dic.Add Tem, K
       For J = 1 To 6
         vlArr(K, J) = IIf(J = 3 Or J = 4, "'" & Arr(I, J), Arr(I, J))
       Next
   Else
      K = K + 1
      vlArr(K, 3) = "'" & Arr(I, 3)
      vlArr(Dic.Item(Tem) + 1, 4) = "'" & Arr(I, 4)
      vlArr(K, 5) = Arr(I, 5)
     If Arr(I, 3) <> Empty Then
      vlArr(Dic.Item(Tem), 6) = vlArr(Dic.Item(Tem), 6) + Arr(I, 6)
     Else
      vlArr(Dic.Item(Tem) + 1, 6) = vlArr(Dic.Item(Tem) + 1, 6) + Arr(I, 6)
    End If
  End If
Next I
 If K Then
 .[H4:M10000].ClearContents
 .[H4].Resize(K, 6) = vlArr
 End If
End With
Set Dic = Nothing
End Sub

 

[nncb2008]

Xin gửi dữ liệu nhiều hơn.