Option Explicit
Public Sub THVBA_CRV___()
'//Khai bao tham so
Dim dic As Object, sheet As Worksheet, cell As Range
Dim data As Variant, result As Variant, key As Variant
Dim i As Long, j As Long, k As Long, r As Long
Dim c As Integer
'// Tang toc code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'// Xac dinh mang du lieu dau vao & kich thuoc mang ket qua dau ra
Set sheet = ThisWorkbook.Worksheets("DL_N")
data = sheet.Range("C3").CurrentRegion.Value
r = UBound(data, 1) * 9: c = 2: k = 1
ReDim result(1 To r, 1 To c)
result(1, 1) = "Ma": result(1, 2) = "Phan Loai"
'// Khoi tao Dictionary
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
'// Lay ten tieu de cot la thang roi gan vao Dic
For j = 10 To UBound(data, 2)
key = "Month|" & data(1, j)
If Not dic.Exists(key) Then
c = c + 1: dic.Add key, c
ReDim Preserve result(1 To r, 1 To c + 2)
result(1, c + 0) = data(1, j)
result(1, c + 1) = "Tong_SN"
result(1, c + 2) = "T_B"
c = c + 2
End If
Next j
'// Xu ly du lieu
For i = 2 To UBound(data, 1)
For j = 1 To 9
key = data(1, j) & "|" & data(i, j)
If Not dic.Exists(key) Then
k = k + 1: dic.Add key, k
result(k, 1) = data(1, j)
result(k, 2) = data(i, j)
If Not IsEmpty(data(i, j)) Then
For c = 10 To UBound(data, 2)
key = "Month|" & data(1, c)
result(k, dic.Item(key)) = result(k, dic.Item(key)) + data(i, c)
Next c
End If
Else
r = dic.Item(key)
If Not IsEmpty(data(i, j)) Then
For c = 10 To UBound(data, 2)
key = "Month|" & data(1, c)
result(r, dic.Item(key)) = result(r, dic.Item(key)) + data(i, c)
Next c
End If
End If
Next j
Next i
'// Tao sheet moi
c = ThisWorkbook.Sheets.Count: r = UBound(result, 2)
Set sheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(c))
'/// Gan ket qua vao sheet moi & ke khung
With sheet
.Name = "T_H_" & c + 1
Set cell = .Cells(3, 1)
cell.Resize(k, r).Value = result
cell.Resize(k, 2).Font.Bold = True
cell.Resize(k, 2).Font.Color = RGB(100, 0, 200)
cell.Resize(k, 2).Interior.Color = RGB(204, 255, 255)
cell.Resize(k, 2).Font.Size = 10
cell.Resize(k, 2).Borders(xlEdgeRight).LineStyle = 1
With cell.CurrentRegion
.Cells.Sort Key1:=cell, Order1:=xlAscending, _
Key2:=cell.Offset(, 1), Order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
With .Cells.Font
.Name = "Times New Roman": .Size = 11
End With
cell.Resize(, r).Font.Bold = True
.Cells.EntireColumn.AutoFit
.Tab.Color = 255
j = cell.Column
i = cell.Row + 1
k = k + i
Do While i <= k
If .Cells(i, j).Value <> key Then
.Cells(i, j).Resize(, r).Borders(xlEdgeTop).LineStyle = xlContinuous
.Cells(i, j).Resize(, r).Borders(xlEdgeTop).Weight = xlThick
.Cells(i, j).Resize(, r).Borders(xlEdgeTop).Color = RGB(121, 121, 121)
key = .Cells(i, j).Value: i = i + 1
Else
.Cells(i, j).Resize(, r).Borders(xlEdgeTop).LineStyle = xlDot
.Cells(i, j).Resize(, r).Borders(xlEdgeTop).Weight = xlThin
.Cells(i, j).Value = Empty: i = i + 1
End If
Loop
End With
'//Tra lai trang thai ban dau - ket thuc tang toc
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'//Thong bao ket thuc
MsgBox "Done and success !", vbInformation + vbOKOnly, "https://tuhocvba.net/"
End Sub
..nên nhiều khi toàn chắp vá..mong được các thành viên góp ý chỉ bảo nhiều.!