Em đã thêm mã (nhập mỏi tay quá.. hi hì..), mong thầy giúp em một cách.!.
Cảm ơn bạn đã giúp mình thêm một cách, mình sẽ từ từ tìm hiểu thêm. Bài tổng hợp này với mình là khó.
Đúng là không có tháng 7, Mình chưa nhận được mail nên không có trong file.
Code của Bạn HieuCD Cộng thêm tố màu và chữ đậm của bạn thật tuyệt vời!.
Public Sub Tonghop()
Dim Dic As Object, Tem As String, Arr(1 To 65535, 1 To 19), Darr()
Dim i As Long, j As Long, k As Long, nk As Long, ik As Long, n As Long
On Error Resume Next
Set Dic = CreateObject("Scripting.Dictionary")
For n = 1 To 12
i = Sheets("T" & n).Range("E65535").End(xlUp).Row ' Gan i la vung du lieu cua cac sheet
If i < 10 Then GoTo Tiep ' i < 10: tiep tuc viec gan du lieu cac vung bang tinh
Darr = Sheets("T" & n).Range("A10:S" & i).Value ' gan mang Darr bang vung du lieu cua cac bang tính T1...T12
For i = 1 To UBound(Darr) ' Vong lap duyet tu phan tu dau den phan tu cuoi cua mang
If Darr(i, 5) <> Empty Then ' kiem tra dieu kien de thuc hien neu cot E cua cac bang tinh T1... khong phai rong
If Darr(i, 3) <> Empty Then Tem = Darr(i, 2) & "#" & Darr(i, 3) & "#" & Darr(i, 4) ' neu cot D cu cac thang khac rong thì tao nhom va ghep du lieu tai cac cot B, C, D
If Not Dic.Exists(Tem) Then ' Kiem tra neu nhom (tem) chua co trong Dic
k = k + 1 ' Tang bien dem len 1
ik = (k - 1) * 100 + 1 ' ?
Dic.Add Tem, ik ' Ghi vào Dic
Arr(ik, 1) = k 'Gan phan tu dau tien cua mang tam bang k
For j = 2 To 4 ' duyet qua cac cot B, C, D gan du lieu tu mang tam vao mang dich
Arr(ik, j) = Darr(i, j)
Next j
Else
ik = Dic.Item(Tem) + 1 ' Neu co trong Dic tang bien dam len 1
Dic.Item(Tem) = ik ' Ghi gia tri moi vào Dic
End If
nk = (Int(ik / 100) + 1) * 100 '?
For j = 5 To 19 ' Duyet tu cot E den cot S trong cac bang tinh T1...
Arr(ik, j) = Darr(i, j) ' Gan mang tam vao mang dich
If j > 7 Then Arr(nk, j) = Arr(nk, j) + Darr(i, j) ' Tinh tu cot H gia tri duoc cong don
Next j
End If
Next i
Tiep:
Next n
ReDim Darr(1 To UBound(Arr), 1 To UBound(Arr, 2)) ' Xac dinh lai kich thuoc mang dich
ik = 0
For i = 1 To k * 100 Step 100 ' Mong duoc ban HieuCD và ban PacificPR cung moi nguoi chu thich dum
For nk = i To i + 98
If Arr(nk, 5) = Empty Then Exit For
ik = ik + 1
For j = 1 To 19
Darr(ik, j) = Arr(nk, j)
Next j
Next nk
ik = ik + 1
For j = 8 To 18
Darr(ik, j) = Arr(i + 99, j)
Next j
Next i
With Sheets("Tong_hop")
.Range("A10:S" & .Range("R65535").End(3).Row + 1).Borders.LineStyle = xlNone
.Range("A10:S" & .Range("R65535").End(3).Row + 1).ClearContents
.Range("A10:S" & .Range("R65535").End(3).Row + 1).Font.Bold = False
.Range("A10:S" & .Range("R65535").End(3).Row + 1).Interior.Color = xlNone
.Range("A10").Resize(ik, 19) = Darr
.Range("A10:S" & .Range("R65535").End(3).Row).Borders.LineStyle = xlContinuous
.Range("A10:S" & .Range("R65535").End(3).Row).Borders(xlInsideHorizontal).Weight = xlHairline
For i = ik + 9 To 10 Step -1
If Range("E" & i) = Empty Then
With .Range("A" & i & ":S" & i)
.Font.Bold = True
.Interior.Color = 13434879
End With
End If
Next i
End With
End SubBạn nên dùng code mới của mình để khắc phục lỗi Font Bold và an toàn hơn
Public Sub Tonghop()
Dim Dic As Object, Tem As String, Arr(1 To 65535, 1 To 19), Darr()
Dim i As Long, j As Long, k As Long, nk As Long, ik As Long, n As Long
' Mang Arr ghi nhan ket qua tam, moi nguoi có 100 dong, nhung dong dau ghi nhan tung cong viec, dòng thu 100 (200, 300...) là dòng tong cong
With Sheets("Tong_hop") 'Xóa vùng du lieu co truoc
i=.Range("R65535").End(3).Row + 1
if i>10 then
.Range("A10:S" & i).Font.Bold = False 'Xoa font Bold
.Range("A10:S" & i).Borders.LineStyle = xlNone 'Xoa duong vien khung
.Range("A10:S" & i).ClearContents 'Xoa du lieu
end if
End With
Set Dic = CreateObject("Scripting.Dictionary")
For n = 1 To 12
If IsNotSheetName("T" & n) Then GoTo Tiep 'Neu sheet "T" & n khong ton tai thì bo qua
i = Sheets("T" & n).Range("E65535").End(xlUp).Row 'Dong cuoi cua bang du lieu
If i < 10 Then GoTo Tiep 'Neu dòng cuoi <10, bang khong co du lieu, bo qua
Darr = Sheets("T" & n).Range("A10:S" & i).Value ' gan mang Darr bang vung du lieu cua cac bang tính T1...T12
For i = 1 To UBound(Darr) ' Vong lap duyet tu phan tu dau den phan tu cuoi cua mang
If Darr(i, 5) <> Empty Then ' kiem tra dieu kien de thuc hien neu cot E cua cac bang tinh T1... khong phai rong
If Darr(i, 3) <> Empty Then Tem = Darr(i, 2) & "#" & Darr(i, 3) & "#" & Darr(i, 4) ' neu cot C (cot Ho) cac thang khac rong thì tao nhom va ghep du lieu tai cac cot B, C, D
'If Darr(i, 3) <> Empty Then Tem = Darr(i, 2) 'Neu có mã so (cot B: Ma so) tung nguoi thì bo dòng lenh tren và thay bang dong lenh nay
If Not Dic.Exists(Tem) Then ' Kiem tra neu nhom (tem) chua co trong Dic
k = k + 1 ' Tang bien dem len 1, k là thu tu cua nguoi thu k
ik = (k - 1) * 100 + 1 ' Thu tu dong trong mang Arr cua nguoi thu k
Dic.Add Tem, ik ' Ghi vào Dic: Key là Tem, Item là thu tu dong cua mang Arr
Arr(ik, 1) = k ' Gán thu tu cua tung nguoi vào cot 1
For j = 2 To 4 ' duyet qua cac cot B, C, D gan du lieu tu mang tam vao mang dich
Arr(ik, j) = Darr(i, j)
Next j
Else
ik = Dic.Item(Tem) + 1 ' Neu co trong Dic tang thu tu dong cua Arr len 1
Dic.Item(Tem) = ik ' Gan thu tu dong moi cua Arr
End If
nk = (Int(ik / 100) + 1) * 100 ' Thu tu dong cua dòng "tong cong" cua nguoi thu k
For j = 5 To 19 ' Duyet tu cot E den cot S trong cac bang tinh T1...
Arr(ik, j) = Darr(i, j) ' Gan mang tam vao mang dich
If j > 7 Then Arr(nk, j) = Arr(nk, j) + Darr(i, j) ' Gan mang tam vao mang dich, cua dong "Tong Cong"
Next j
End If
Next i
Tiep: ' Diem nhay bo qua cac dòng lenh tren neu sheet khong có và du lieu khong có
Next n
ReDim Darr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'Tao mang Darr ghi nhan ket qua, loai bo cac dòng khong có du lieu trong mang Arr
ik = 0
For i = 1 To k * 100 Step 100 ' Xet nguoi thu i (có k nguoi)
For nk = i To i + 98 ' xet cac dòng ghi nhan cong viec, tu dòng dau den dòng cuoi: 1 toi 99,101 toi 199,201 toi 299 ...
If Arr(nk, 5) = Empty Then Exit For ' Neu het du lieu thi ngung vong lap
ik = ik + 1 ' ik là thu tu dòng mang ket qua, thu tu dong tang len 1
For j = 1 To 19 ' Duyet tat ca các cot mang ket qua (tu cot A den cot S trong sheet)
Darr(ik, j) = Arr(nk, j) ' Gan mang tam vao mang ket qua
Next j
Next nk
ik = ik + 1 ' thu tu dong "tong cong"
For j = 8 To 18 ' Duyet các cot mang ket qua dòng "tong cong" (tu cot H den cot R trong sheet)
Darr(ik, j) = Arr(i + 99, j) ' Gán ket qua vào dong "tong cong"
Next j
Sheets("Tong_hop").Range("A9:S9").Offset(ik).Font.Bold = True 'Dinh dang font là Bold cho dong "tong cong"
Next i
With Sheets("Tong_hop")
.Range("A10").Resize(ik, 19) = Darr ' Gán ket qua vào sheet
.Range("A10:S" & .Range("R65535").End(3).Row + 1).Borders.LineStyle = xlContinuous 'Ke khung toàn bô
.Range("A10:S" & .Range("R65535").End(3).Row + 1).Borders(xlInsideHorizontal).Weight = xlHairline ' duong khung ngang o giua nho hon ngoai bien
End With
End Sub
Private Function IsNotSheetName(ShName As String) As Boolean
' kiem tra sheet khong ton tai
' Neu Sheet khong ton tai tra ve True, nguoi lai Sheet ton tai tra ve False
Dim Tmp As String
On Error Resume Next ' Neu gap loi thì bo qua, chay tiep các dong lenh duoi
Tmp = Sheets(ShName).Name ' Bay loi
If Err.Number <> 0 Then ' Neu bi loi
IsNotSheetName = True ' ket qua Function là True (Sheet khong ton tai)
Err.Clear ' Xoa loi
End If
End FunctionMình cảm ơn bạn đã giúp, với chú thích trên code mình có thể tìm hiểu thuận lợi hơn!. Mình sẽ tìm hiểu, áp dụng nếu còn điều gì vướng mắc mong được Bạn và mọi người giúp mình.
Em cảm ơn Thầy Ba Tê giúp em. Em có thêm một cách nữa để nghiên cứu, áp dụng. Thầy Ba Tê ơi trong code không cần lấy danh sách ở sheet GV có đúng không ạ?.
Nếu vậy em dùng Name: OFFSET(GV!$B$6,0,0,COUNTA(GV!$B$6:$B$9899),1) để lấy mã nhập cho cột mã ở các sheet T1-T12 này dùng data validation để chọn mã:
Option Explicit
Public Sub thi_nghiem()
Application.ScreenUpdating = False
Dim sArr, kq(), i, J, K, n As Long
Dim Rws As Long, R As Long
'--------------------------------------------------------------------------------
With Sheets("Tong_hop")
Rws = .Range("G10000").End(xlUp).Row
sArr = .Range("A10:S" & Rws).Value: R = UBound(sArr)
End With
ReDim kq(1 To UBound(sArr), 1 To 19)
For i = 1 To R
If sArr(i, 2) <> "" Then
K = K + 1
kq(K, 1) = K
For J = 2 To 4
kq(K, J) = sArr(i, J)
Next J
' If sArr(i, 5) = "" Then 'den day lam the nao de lay duoc cac cot cua dong tong ?
'them vong lap ?
' kq(K, 5) = sArr(n, 5)
' kq(K, 6) = ""
' kq(K, 7) = ""
' For J = 8 To 19
' kq(K, J) = sArr(n, J)
' Next J
' End If
End If
Next i
'-----------------------------------------------------------------------------------
If K Then
With Sheets("Bao_cao")
.[A10].Resize(K, 19).ClearContents
.[A10].Resize(K, 19).Value = kq
.[A10].Resize(K, 19).Borders.LineStyle = xlNone
.[A10].Resize(K, 19).Borders.LineStyle = xlContinuous
.[A10].Resize(K, 19).Borders(xlInsideHorizontal).Weight = xlHairline
.[C10].Resize(K, 2).Borders(xlInsideVertical).LineStyle = xlNone
End With
End If
Application.ScreenUpdating = True
End Sub
Thử vầy xem sao, theo file bài của tôi bên trên, thêm "màu mè" nữa tùy bạn.
Public Sub S_BCao()
Dim sArr(), dArr(), I As Long, J As Long, N As Long, K As Long, R As Long
With Sheets("Tong_hop")
sArr = .Range("A10", .Range("G50000").End(xlUp)).Resize(, 19).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 19)
End With
For I = 1 To R
If sArr(I, 2) <> Empty Then
K = K + 1
For J = 1 To 4
dArr(K, J) = sArr(I, J)
Next J
For N = I + 1 To R
If sArr(N, 7) = "TOTAL:" Then
For J = 7 To 19
dArr(K, J) = sArr(N, J)
Next J
I = N: Exit For
End If
Next N
End If
Next I
With Sheets("Bao_Cao")
.Range("A10").Resize(K, 19) = dArr
End With
End Sub[/QUOTE]
For N = I + 1 To R
If sArr(N, 7) = "TOTAL:" Then
For J = 7 To 19
dArr(K, J) = sArr(N, J)
Next J
I = N: Exit For
End If
Next NThầy Ba Tê và mọi người xem giúp em file trên bài 26 với!.
Mình có xem code một số bài bạn viết cũng rất hay mà, sử lý được các bài phức tạp. Mình đọc trên GPE nhiều mà chẳng tiến bộ tý nào về viết code cet, có chăng chỉ biết sử dngj một số tiện ích mọi người viết
Vẫn là file trên bài 26. Khi Dòng đầu có dữ liệu thì kết quả TOTAL: không chính xác, mình đã Sum kết quả ở trong file với trường hợp cuối. Mong các bạn xem giúp
