Mọi người chào em, em vui lòng sửa tiêu đề cho phù hợp Nội quy nhé.
Line1 có dòng input là thế nào? tổng hợp có đem qua không?
Hihi. Em là gà mờ nên chỉ dùng code tổng hợp theo hàng theo cột. Nên sau lần sort đầu vị trí hàng thay đổi nên lần tổng hợp tiếp theo sai kết quả luôn.
Ok admin. Em sẽ sửa
Dạ có. Nó là đầu vào để em tính % nên tổng luôn ạ.
Option Explicit
Sub Thong_Ke()
Dim Ws As Worksheet
Dim i&, R&, C%, Names$, K&, Times$, Col&, j&
Dim Dic As Object
Dim DL(), KQ()
Set Dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------
With Sheet1
C = .Range("XFD3").End(xlToLeft).Column - 1
DL = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Resize(, C).Value
R = UBound(DL)
ReDim KQ(1 To R - 1, 1 To C - 2)
For i = 2 To UBound(DL)
Names = Trim(DL(i, 1))
If Not Dic.exists(Names) Then Dic.Add Names, i - 1
Next
For i = 3 To UBound(DL, 2)
Times = Trim(DL(1, i))
If Not Dic.exists(Times) Then Dic.Add Times, i - 2
Next
End With
For Each Ws In ActiveWorkbook.Worksheets
If Ws.Name <> "tonghop" Then
With Ws
C = .Range("XFD3").End(xlToLeft).Column - 1
If C > 1 Then
DL = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Resize(, C).Value
For i = 2 To UBound(DL)
Names = Trim(DL(i, 1))
If Dic.exists(Names) Then
For j = 2 To C
Times = Trim(DL(1, j))
If Dic.exists(Times) Then
Col = Dic.Item(Times)
K = Dic.Item(Names)
KQ(K, Col) = KQ(K, Col) + DL(i, j)
End If
Next
End If
Next
End If
End With
End If
Next
Set Dic = Nothing
Sheet1.Range("D4").Resize(UBound(KQ), UBound(KQ, 2)).ClearContents
Sheet1.Range("D4").Resize(UBound(KQ), UBound(KQ, 2)) = KQ
Sheet1.Range("A3").Resize(UBound(DL), UBound(DL, 2) + 1).Borders.LineStyle = 1
Sheet1.Range("A3").Resize(UBound(KQ), UBound(KQ, 2)).Sort Key1:=Sheet1.Range("c3"), Order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
End SubCảm ơn anh nhé. Em test thử chạy ok. Nhưng mà em chèn thêm 2 cột với
cảm ơn cụ nhé. Em chạy ok rùi. Cơ mà em thêm 2 cột tỷ lệ vào giữa tổng và bên số liệu. Sửa lại code 1 chút thì dòng
cảm ơn cụ nhé. Code chạy ok. Cơ mà em thêm hai cột bên trái cái total. Sửa lại code mà bị fail. 2 cột đấy em để % của name so với tổng. Cụ giúp em được không.
Thêm mỗi code ở sheets tonghop hay tất cả cá sheets điều thêm? và nếu thêm vào tất cả cá sheets thì có lấy hai code đó không? Với hỏi thêm là cái danh sách name và ngày ở sheets tổng hợp (điều kiện để lọc) là có sẵn ở đó rồi chỉ cần tổng hợp theo danh sách đó,hay là chưa có sẵn mà chạy qua các sheets tổng hợp về (vì hiện tại tôi đang hiểu là nó đã có sẵn ở đó và lấy kết quả theo điều kiện định sẵn ở đó) .Nếu là chưa có thì code sẽ phải sửa lại.Bạn cho xin cái file miêu tả kết quả mong muốn làm bằng tay đước không?
Option Explicit
Sub Thong_Ke()
Dim Ws As Worksheet
Dim i&, R&, C%, Names$, K&, Times$, Col&, j&
Dim Dic As Object
Dim DL(), KQ()
Dim t As Integer
Set Dic = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------
With Sheet1
C = .Range("XFD16").End(xlToLeft).Column - 1
DL = .Range("B16", .Range("B" & Rows.Count).End(xlUp)).Resize(, C).Value
R = UBound(DL)
ReDim KQ(1 To R - 1, 1 To C - 4)
For i = 2 To UBound(DL)
Names = Trim(DL(i, 1))
If Not Dic.exists(Names) Then Dic.Add Names, i - 1
Next
For i = 5 To UBound(DL, 2)
Times = Trim(DL(1, i))
If Not Dic.exists(Times) Then Dic.Add Times, i - 4
Next
End With
For Each Ws In ActiveWorkbook.Worksheets
If Ws.Name <> "tonghop" Then
With Ws
C = .Range("XFD16").End(xlToLeft).Column - 1
If C > 1 Then
DL = .Range("B16", .Range("B" & Rows.Count).End(xlUp)).Resize(, C).Value
For i = 2 To UBound(DL)
Names = Trim(DL(i, 1))
If Dic.exists(Names) Then
For j = 5 To C
Times = Trim(DL(1, j))
If Dic.exists(Times) Then
Col = Dic.Item(Times)
K = Dic.Item(Names)
KQ(K, Col) = KQ(K, Col) + DL(i, j)
End If
Next
End If
Next
End If
End With
End If
Next
Set Dic = Nothing
Sheet1.Range("F17").Resize(UBound(KQ), UBound(KQ, 2)) = KQ
Sheet1.Range("A16").Resize(UBound(DL), UBound(DL, 2) + 1).Sort Key1:=Sheet1.Range("A16"), Order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
End SubCảm ơn cụ đã giúp nhiệt tình nhé. Code chạy rất ổn và đúng ý. Nhờ cụ mà em thông não được khá nhiều vấn đề. Em phải chịu khó nâng cấp bản thân mới được. Mong 1 ngày giỏi như cụ.
