Bạn lưu ý là mình đang kẻ bảng bằng Condition Format nếu bạn delete dòng thì vùng định dạng sẽ ít đi. Khi đó 1 số dòng không được kẻ bảng, bạn sử lý bằng chép định dạng xuống nha.
Dưới đây mình xin diễn giải code của bài, bạn tham khảo nha:
[GPECODE=vb]'******************************************
'********* GiaiphapExcel.com **************
'******************************************
Option Explicit
Sub NKChung()
'Khai bao cac bien can dung
Dim Tm, Kq(), i, j, x
Dim Dic As Object
Dim Thg, SThg, Snam
'Tao 1 tu dien de ghi nho danh sach cac chung tu va phong khi can cong tong theo chung tu
Set Dic = CreateObject("Scripting.Dictionary")
'Sap xep lai du lieu theo thang va so chung tu
With Sheet1
.Range(.Rows(3), .Rows(65536).End(3)).Sort Key1:=.Range("C4"), Order1:=1, _
Key2:=.Range("B4"), Order2:=1, Key3:=.Range("H4"), Order3:=1, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
'Gan bien Tm bang toan bo du lieu de lam viec tren bien mang toc do cao hon
Tm = .Range(.[A4:AG4], .[A65536:AG65536].End(3))
End With
For i = 1 To UBound(Tm, 1)
'Neu Cot Ngay <>"" va dinh khoan khac "" va chua co trong tu dien thi them vao chung tu moi
If Tm(i, 8) <> 0 And Tm(i, 20) <> "" And Tm(i, 21) <> "" And Not Dic.exists(Tm(i, 4) & Tm(i, 8)) Then
j = j + 1: x = x + 1
Dic.Add Tm(i, 4) & Tm(i, 8), j
ReDim Preserve Kq(1 To 8, 1 To x)
Kq(1, x) = Tm(i, 1)
Kq(2, x) = Tm(i, 4)
Kq(3, x) = Tm(i, 8)
Kq(4, x) = Tm(i, 7)
Kq(5, x) = Tm(i, 33)
End If
'Them chi tiet cho chung tu
If Tm(i, 20) <> "" And Tm(i, 21) <> "" Then
x = x + 1
ReDim Preserve Kq(1 To 8, 1 To x)
Kq(6, x) = Tm(i, 20)
Kq(7, x) = Tm(i, 21)
Kq(8, x) = Tm(i, 17)
SThg = SThg + Tm(i, 17)
Snam = Snam + Tm(i, 17)
End If
'Neu chua co thang thi dat thang bang thang bat dau
If Thg = "" Then
Thg = Tm(i, 3)
'Neu het du lieu thi them dong cong thang va cong nam
ElseIf i = UBound(Tm, 1) Then
ReDim Preserve Kq(1 To 8, 1 To x + 2)
Kq(1, x + 1) = "<<>>"
Kq(5, x + 1) = "C" & ChrW(7897) & "ng th" & ChrW(225) & "ng " & Thg
Kq(8, x + 1) = SThg
Kq(1, x + 2) = "<<>>"
Kq(5, x + 2) = "C" & ChrW(7897) & "ng n" & ChrW(259) & "m "
Kq(8, x + 2) = Snam
'Neu sang thang moi thi them dong cong thang
ElseIf Thg <> Tm(i + 1, 3) Then
x = x + 1
ReDim Preserve Kq(1 To 8, 1 To x)
Kq(1, x) = "<<>>"
Kq(5, x) = "C" & ChrW(7897) & "ng th" & ChrW(225) & "ng " & Thg
Kq(8, x) = SThg
Thg = Tm(i + 1, 3)
SThg = 0
End If
Next
Sheet2.[A9:H65536].ClearContents 'Xoa Nhat ky cu
'Dien so lieuj moi
Sheet2.[A9].Resize(UBound(Kq, 2), UBound(Kq, 1)) = Application.Transpose(Kq)
'Xoa cac bien
Erase Kq
Set Dic = Nothing
End Sub[/GPECODE]
Bạn lưu ý là code sổ cái sử lý khác Code này vì cấu trúc sổ cái hoàn toàn khác.
