Gửi lại Phong Trần file chạy VBA: nhớ Enable macro khi nó hỏi. Khi cần tổng hợp thì nhấn nút "tổng hợp" màu xanh.
http://www.mediafire.com/file/7jskkd5k38duscg/15717.xlsm
Code tham khảo:
Sub TongHop()
Dim i as Integer
Dim as Integer
Dim KQarr(1 To 10000, 1 To 11)
lr = Sheets("Copy Value").Range("D" & Rows.Count).End(xlUp).Row
DataArr = Sheets("Copy Value").Range("A3:G" & lr).Value
j = 0
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) <> "" Then
j = j + 1
KQarr(j, 1) = DataArr(i, 1)
KQarr(j, 2) = DataArr(i, 2)
If j > 1 Then
KQarr(j - 1, 3) = Mid(KQarr(j - 1, 3), 3, Len(KQarr(j - 1, 3)))
KQarr(j - 1, 4) = Mid(KQarr(j - 1, 4), 3, Len(KQarr(j - 1, 4)))
KQarr(j - 1, 5) = Mid(KQarr(j - 1, 5), 3, Len(KQarr(j - 1, 5)))
KQarr(j - 1, 6) = Mid(KQarr(j - 1, 6), 3, Len(KQarr(j - 1, 6)))
KQarr(j - 1, 8) = Mid(KQarr(j - 1, 8), 3, Len(KQarr(j - 1, 8)))
KQarr(j - 1, 9) = Mid(KQarr(j - 1, 9), 3, Len(KQarr(j - 1, 9)))
KQarr(j - 1, 10) = Mid(KQarr(j - 1, 10), 3, Len(KQarr(j - 1, 10)))
KQarr(j - 1, 11) = Mid(KQarr(j - 1, 11), 3, Len(KQarr(j - 1, 11)))
End If
Else
If DataArr(i, 3) = "Alu" Then
KQarr(j, 3) = KQarr(j, 3) & "; " & DataArr(i, 6)
KQarr(j, 4) = KQarr(j, 4) & "; " & DataArr(i, 7)
KQarr(j, 5) = KQarr(j, 5) & "; " & DataArr(i, 4)
KQarr(j, 6) = KQarr(j, 6) & "; " & DataArr(i, 5)
ElseIf DataArr(i, 3) = "Dle" Then
KQarr(j, 8) = KQarr(j, 8) & "; " & DataArr(i, 6)
KQarr(j, 9) = KQarr(j, 9) & "; " & DataArr(i, 7)
KQarr(j, 10) = KQarr(j, 5) & "; " & DataArr(i, 4)
KQarr(j, 11) = KQarr(j, 6) & "; " & DataArr(i, 5)
End If
End If
Next i
KQarr(j, 3) = Mid(KQarr(j, 3), 3, Len(KQarr(j, 3)))
KQarr(j, 4) = Mid(KQarr(j, 4), 3, Len(KQarr(j, 4)))
KQarr(j, 5) = Mid(KQarr(j, 5), 3, Len(KQarr(j, 5)))
KQarr(j, 6) = Mid(KQarr(j, 6), 3, Len(KQarr(j, 6)))
KQarr(j, 8) = Mid(KQarr(j, 8), 3, Len(KQarr(j, 8)))
KQarr(j, 9) = Mid(KQarr(j, 9), 3, Len(KQarr(j, 9)))
KQarr(j, 10) = Mid(KQarr(j, 10), 3, Len(KQarr(j, 10)))
KQarr(j, 11) = Mid(KQarr(j, 11), 3, Len(KQarr(j, 11)))
Sheets("Copy Value").Range("I3:S10000").Delete
Sheets("Copy Value").Range("I3:S" & j + 2).Value = KQarr
Sheets("Copy Value").Range("I3:N" & j + 2).Borders.LineStyle = xlContinuous
Sheets("Copy Value").Range("P3:S" & j + 2).Borders.LineStyle = xlContinuous
Sheets("Copy Value").Range("I3:S" & j + 2).WrapText = True
Set DataArr = nothing
End Sub
