Bạn thử đoạn code này xem sao. Kết quả đang để ở dòng A20 để so sánh.
Sub XYZ()
Dim i&, k&, t&, R&
Dim Arr(), KQ()
Dim Sh As Worksheet
Dim Dic As Object
Set Sh = Sheet3
Arr = Sh.Range("A2:E11").Value ' nếu dữ liệu nhiều hơn thì phải tìm dòng cuối và khi đó Arr=Sh.range("A2:E"& dongcuoi).value
R = UBound(Arr)
Set Dic = CreateObject("Scripting.Dictionary")
ReDim KQ(1 To R, 1 To 3)
For i = 1 To R
Keys = Arr(i, 1)
If Not Dic.Exists(Keys) Then
t = t + 1
Dic.Add (Keys), t
KQ(t, 1) = Keys
KQ(t, 2) = "Ngày " & Arr(i, 2) & Sh.[C1] & " " & Arr(i, 3) & " " & Sh.[D1] & " " & Arr(i, 4) & " -" & Sh.[E1] & " " & Arr(i, 5)
KQ(t, 3) = Arr(i, 4)
Else
k = Dic.Item(Keys)
KQ(k, 2) = KQ(k, 2) & Chr(10) & "Ngày " & Arr(i, 2) & Sh.[C1] & " " & Arr(i, 3) & " " & Sh.[D1] & " " & Arr(i, 4) & " -" & Sh.[E1] & " " & Arr(i, 5)
KQ(k, 3) = KQ(k, 3) + Arr(i, 4)
End If
Next
If t Then
Sh.Cells(20, 1).Resize(R + 10, 3).ClearContents
Sh.Cells(20, 1).Resize(R + 10, 3) = KQ
End If
Set Dic = Nothing
End Sub
Module nào có dòng Option Explicit trên cùng, sẽ bị lỗi biến Keys
Nếu dữ liệu đã sắp xếp như trong cột A, cũng không cần tới Dictionary.
Cảm ơn Anh đã chỉ giáo. Tôi sẽ rút kinh nghiệm. Đưa những Cái Sh.[C1]... vào thành biến (ngay=Sh.[C1].....) thì code sẽ nhẹ hơn,và dễ kiểm tra hơn....
Cảm ơn bạn đã giúp đỡ, thật tuyệt vời.
Bài của em được Anh Ba Tê ngó tới là em thấy vui rồi! Em cảm ơn anh nhé
Bạn dùng bảng dữ liệu và bảng Kết quả chung 1 sheet, với code như của bạn thì chạy Sub nhiều lần sẽ thành "từa lưa" hết, do biến lastrow của bạn sau mỗi lần chạy sẽ không còn là 523 dòng nữa.
Thử code này coi
Sub ABC()
Dim sArr(), iRow&, Res(), i&, Dic As Object, K&, KK&
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("Data")
iRow = .Range("A" & Rows.Count).End(3).Row
sArr = .Range("A1:E" & iRow).Value
End With
ReDim Res(1 To UBound(sArr, 1), 1 To 3)
For i = 2 To UBound(sArr, 1)
If Dic.exists(sArr(i, 1)) = False Then
K = K + 1
Dic.Add (sArr(i, 1)), K
Res(K, 1) = sArr(i, 1)
Res(K, 2) = sArr(1, 2) & sArr(i, 2) & sArr(1, 3) & sArr(i, 3) & sArr(1, 4) & Format(sArr(i, 4), "0,00#") & sArr(1, 5) & sArr(i, 5)
Res(K, 3) = Format(sArr(i, 4), "0,00#")
Else
KK = Dic.Item(sArr(i, 1))
Res(KK, 2) = Res(KK, 2) & vbCrLf & sArr(1, 2) & sArr(i, 2) & sArr(1, 3) & sArr(i, 3) & sArr(1, 4) & Format(sArr(i, 4), "0,00#") & sArr(1, 5) & sArr(i, 5)
Res(KK, 3) = Format(Res(KK, 3) + sArr(i, 4),"0,00#")
End If
Next
With Sheets("KQ")
If K Then
.Range("A2:C1000").Clear
.Range("A2").Resize(K, 3).Value = Res
.Range("A2").Resize(K, 3).Borders.LineStyle = 1
End If
End With
End SubCảm ơn anh Ba Tê , kết quả thật tuyệt vời
Cảm ơn bạn , mình tham khảo cách của bạn cũng rất hay.
