Bạn thử dùng Consolidate xemDữ liệu ở Cột C "Tên vật tư" và cột D " Khối lượng" sẽ được tổng cộng lại ở các sheet (01 đến 10 ) vào sheet "Tong hop"View attachment 199909View attachment 199910View attachment 199911
Em xin cám ơn nhìu!
Bạn thử dùng Consolidate xemView attachment 199914
E cám ơn a! Cái này chắc dùng code nhanh hơn đúng không Chị?Bạn thử dùng Consolidate xemView attachment 199914
Bạn tự kiểm tra nhé.Dữ liệu ở Cột C "Tên vật tư" và cột D " Khối lượng" sẽ được tổng cộng lại ở các sheet (01 đến 10 ) vào sheet "Tong hop"View attachment 199909View attachment 199910View attachment 199911
Em xin cám ơn nhìu!
Sub GPE()
'On Error Resume Next
Dim Dic, dArr(1 To 1000, 1 To 8), Arr, Tmp
Dim i As Long, m As Long, j As Long, k As Long
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To 10
With Sheets(Format(i, "00"))
Arr = .UsedRange.Value
For j = 2 To UBound(Arr)
Tmp = Arr(j, 3)
With Dic
If Not .Exists(Tmp) Then
k = k + 1
.Add Tmp, k
dArr(k, 1) = k
For m = 1 To 7
dArr(k, m + 1) = Arr(j, m + 1)
Next m
Else
dArr(.Item(Tmp), 4) = dArr(.Item(Tmp), 4) + Arr(j, 4)
End If
End With
Next j
End With
Next i
With Sheet2
.[A2:H1000].ClearContents
If k Then .[A2].Resize(k, 8).Value = dArr
End With
Set Dic = Nothing
End Sub
Vâng, E cám ơn Thầy ạ!Bạn tự kiểm tra nhé.
Mã:Sub GPE() 'On Error Resume Next Dim Dic, dArr(1 To 1000, 1 To 8), Arr, Tmp Dim i As Long, m As Long, j As Long, k As Long Set Dic = CreateObject("Scripting.Dictionary") For i = 1 To 10 With Sheets(Format(i, "00")) Arr = .UsedRange.Value For j = 2 To UBound(Arr) Tmp = Arr(j, 3) With Dic If Not .Exists(Tmp) Then k = k + 1 .Add Tmp, k dArr(k, 1) = k For m = 1 To 7 dArr(k, m + 1) = Arr(j, m + 1) Next m Else dArr(.Item(Tmp), 4) = dArr(.Item(Tmp), 4) + Arr(j, 4) End If End With Next j End With Next i With Sheet2 .[A2:H1000].ClearContents If k Then .[A2].Resize(k, 8).Value = dArr End With Set Dic = Nothing End Sub
E chạy thấy báo lỗi, là do đâu vậy ạ!Bạn tự kiểm tra nhé.
Mã:Sub GPE() 'On Error Resume Next Dim Dic, dArr(1 To 1000, 1 To 8), Arr, Tmp Dim i As Long, m As Long, j As Long, k As Long Set Dic = CreateObject("Scripting.Dictionary") For i = 1 To 10 With Sheets(Format(i, "00")) Arr = .UsedRange.Value For j = 2 To UBound(Arr) Tmp = Arr(j, 3) With Dic If Not .Exists(Tmp) Then k = k + 1 .Add Tmp, k dArr(k, 1) = k For m = 1 To 7 dArr(k, m + 1) = Arr(j, m + 1) Next m Else dArr(.Item(Tmp), 4) = dArr(.Item(Tmp), 4) + Arr(j, 4) End If End With Next j End With Next i With Sheet2 .[A2:H1000].ClearContents If k Then .[A2].Resize(k, 8).Value = dArr End With Set Dic = Nothing End Sub
Có lỗi nào đâu bạn? test thử cho bạn có thấy lỗi gì đâu kết quả ok mà.Vâng, E cám ơn Thầy ạ!
Bài đã được tự động gộp:
E chạy thấy báo lỗi, là do đâu vậy ạ!View attachment 200019
File bạn up lên diễn đàn và file bạn chạy không phải là một file, file bạn up name của các bảng tính là Sheet...., hình bạn chụp lên name của các bảng tính là Trang_tinh... nên code bị lỗi là phải rồi.Vâng, E cám ơn Thầy ạ!
Bài đã được tự động gộp:
E chạy thấy báo lỗi, là do đâu vậy ạ!View attachment 200019
E insert vào mudule và chạy mà, nhờ Anh (Chị ) kiểm tra lại giúp E ạ!File bạn up lên diễn đàn và file bạn chạy không phải là một file, file bạn up name của các bảng tính là Sheet...., hình bạn chụp lên name của các bảng tính là Trang_tinh... nên code bị lỗi là phải rồi.
Có lỗi nào đâu bạn? test thử cho bạn có thấy lỗi gì đâu kết quả ok mà.[/QUOT
Vâng, không hiểu sao Em chạy code vẫn thấy báo lỗi ạ!
Anh (Chị) gửi lại file mà đã Test cho e xin được không ạ!Có lỗi nào đâu bạn? test thử cho bạn có thấy lỗi gì đâu kết quả ok mà.
Bạn download file bạn đã up lên ở bài #1 rồi bỏ vào là chạy thôi mà.Anh (Chị) gửi lại file mà đã Test cho e xin được không ạ!
Bạn chỉnh sửa code để:Bạn tự kiểm tra
Cảm ơn bạn nhé!Bạn xem file này nhé. Mình mới tập code chắc chưa tối ưu lắm.
Mình có tạo thêm 1 sheets("TH") để tổng hợp DL thô trong tất cả các sheet vào 1 sheet. Và có 1 cái tính tổng như yêu cầu của bạn.
Bạn đóng góp ý kiến để cùng học hỏi nhé.
Mượn code của giải pháp để viết theo khuôn mẫu. Cảm ơn giải pháp nhiều nhaBạn tự kiểm tra nhé.
Sub main()
Dim i As Long
Dim K As Long
Dim Arr_D(1 To 1000, 1 To 8)
Dim Dic As Object
Dim Sh As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
K = 0
For i = 1 To 10
Call Khuon(Sheets(Format(i, "00")), Dic, Arr_D, K)
Next
Sheet2.Range("A2:Z10000").Clear
Sheet2.Range("A2").Resize(K, 8) = Arr_D
Set Dic = Nothing
End Sub
Sub Khuon(Sh As Worksheet, Dic As Object, Arr_D(), K As Long)
Dim Arr_N()
Dim i As Long, J As Long, Dcuoi As Long
Dcuoi = Sh.Range("C10000").End(xlUp).Row
Arr_N = Sh.Range("A2:H" & Dcuoi)
For i = 1 To UBound(Arr_N, 1)
If Trim(Arr_N(i, 3)) <> "" Then
If Not Dic.Exists(Arr_N(i, 3)) Then
K = K + 1
Dic.Add Arr_N(i, 3), K
Arr_D(K, 1) = K
For J = 2 To 8
Arr_D(K, J) = Arr_N(i, J)
Next J
Else
Arr_D(Dic.Item(Arr_N(i, 3)), 4) = Arr_D(Dic.Item(Arr_N(i, 3)), 4) + Arr_N(i, 4)
End If
End If
Next i
End Sub
Bạn xem file này nhé. Mình mới tập code chắc chưa tối ưu lắm.
Mình có tạo thêm 1 sheets("TH") để tổng hợp DL thô trong tất cả các sheet vào 1 sheet. Và có 1 cái tính tổng như yêu cầu của bạn.
Bạn đóng góp ý kiến để cùng học hỏi nhé.
E cám ơn Anh ạ!Mượn code của giải pháp để viết theo khuôn mẫu. Cảm ơn giải pháp nhiều nha
Mã:Sub main() Dim i As Long Dim K As Long Dim Arr_D(1 To 1000, 1 To 8) Dim Dic As Object Dim Sh As Worksheet Set Dic = CreateObject("Scripting.Dictionary") K = 0 For i = 1 To 10 Call Khuon(Sheets(Format(i, "00")), Dic, Arr_D, K) Next Sheet2.Range("A2:Z10000").Clear Sheet2.Range("A2").Resize(K, 8) = Arr_D Set Dic = Nothing End Sub Sub Khuon(Sh As Worksheet, Dic As Object, Arr_D(), K As Long) Dim Arr_N() Dim i As Long, Ii As Long, J As Long, Dcuoi As Long Dcuoi = Sh.Range("C10000").End(xlUp).Row Arr_N = Sh.Range("A2:H" & Dcuoi) For i = 1 To UBound(Arr_N, 1) If Trim(Arr_N(i, 3)) <> "" Then If Not Dic.Exists(Arr_N(i, 3)) Then K = K + 1 Dic.Add Arr_N(i, 3), K Arr_D(K, 1) = K For J = 2 To 8 Arr_D(K, J) = Arr_N(i, J) Next J Else Arr_D(Dic.Item(Arr_N(i, 3)), 4) = Arr_D(Dic.Item(Arr_N(i, 3)), 4) + Arr_N(i, 4) End If End If Next i End Sub
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2