Không phải vậy!
Option Explicit
Private Sub Worksheet_Activate()
Dim i As Double, j As Long, l As Long, k As Long, ngay As Date, t As Single
Application.ScreenUpdating = False
Application.Calculation = xlManual
t = Timer
l = Sheet1.Range("B1048576").End(xlUp).Row
With Sheet2
For j = 4 To 300
For k = 5 To 32 Step 3
If Cells(2, k + 4) > 0 Then
ngay = Cells(2, k + 4)
Else
ngay = 402133
End If
If Cells(2, k + 1) > 0 Then
i = WorksheetFunction.SumIfs(Sheet1.Range("E5:E" & l), Sheet1.Range("B5:B" & l), Sheet2.Range("B" & j), Sheet1.Range("A5:A" & l), "<" & ngay)
Sheet2.Cells(j, k) = i
'Else
'Sheet2.Cells(j, k) = ""
End If
Next k
Next j
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
MsgBox Timer - t
End Sub
Cám ơn concogia đã quan tâm!
Hihi, bi giờ mình thử nói lại xem trúng hông há
ic Sub NhapA()
Dim d As Object, Vung As Range, Ngay As Range, nDau, nCuoi, I As Long, J As Long, DuLieu, Cll '
Bạn thử code này nhé.
Sub tinhtong()
Dim arr, i As Long, j As Long, lr As Long, a As Long, dic As Object, data, lc As Long, dk As String, b As Long, lr1 As Long, c As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("CHECK")
lr = .Range("B" & Rows.Count).End(xlUp).Row
lc = .Cells(2, Columns.Count).End(xlToLeft).Column
If lr < 3 Or lc < 3 Then Exit Sub
.Range("C3").Resize(lr - 2, lc - 2).ClearContents
arr = .Range("b2").Resize(lr - 1, lc - 1).Value
For i = 3 To UBound(arr, 2)
b = CLng(arr(1, i))
dic.Item(b) = i
Next i
For i = 2 To UBound(arr)
dk = arr(i, 1)
dic.Item(dk) = i
Next i
End With
With Sheets("SODER")
lr1 = .Range("A" & Rows.Count).End(xlUp).Row
data = .Range("A2:C" & lr1).Value
For i = 1 To UBound(data)
dk = data(i, 1)
a = dic.Item(dk)
If a Then
b = quydoi(data(i, 2))
c = dic.Item(b)
If c Then
arr(a, c) = arr(a, c) + data(i, 3)
End If
End If
Next i
End With
With Sheets("STOCK")
lr1 = .Range("A" & Rows.Count).End(xlUp).Row
data = .Range("A2:C" & lr1).Value
For i = 1 To UBound(data)
dk = data(i, 1)
a = dic.Item(dk)
If a Then
arr(a, 2) = arr(a, 2) + data(i, 3)
End If
Next i
End With
With Sheets("CHECK")
.Range("b2").Resize(lr - 1, lc - 1).Value = arr
End With
End Sub
Function quydoi(ByVal dk As String) As Long
quydoi = CLng(DateSerial(Left(dk, 4), Mid(dk, 5, 2), Mid(dk, 7, 2)))
End Function
Kiểm tra codeXin chào snow25
Cảm ơn bạn đã giúp đỡ, nhìn code dữ thấy ớn quá
------
T_T Híc thực sự xin lỗi bạn và mọi người rất nhiều, OT có bổ sung thêm 1 sheet "PRODUCTION" để thuận tiện nhất việc theo dõi.
Nhờ bạn và mọi người code them giúp vùng "AI3:BL371" trong sheet check ạ.
Sub CongTheoDieuKien()
Dim sArr(), Res(), Res2(), Res3(), Dic As Object, iKey As String, Ngay
Dim i As Long, iRow As Long, j As Long, jCol As Long
Dim eRow As Long, sRow As Long, sCol2 As Long, sCol3 As Long
Dim Rng As Range, rngRes2 As Range, rngRes3 As Range
Const Ngay_Res2 As String = "D2:AG2"
Const Ngay_Res3 As String = "AI2:BL2"
Set Dic = CreateObject("scripting.dictionary")
With Sheets("CHECK")
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow < 3 Then MsgBox ("Khong co du lieu!"): Exit Sub
sArr = .Range("B3:B" & eRow).Value
sRow = UBound(sArr)
ReDim Res(1 To sRow, 1 To 1)
For i = 1 To sRow
iKey = sArr(i, 1)
If Dic.exists(iKey) = False Then Dic.Add iKey, i
Next i
Set Rng = .Range(Ngay_Res2)
Set rngRes2 = Rng(1, 1).Offset(1)
sCol2 = Rng.Columns.Count
ReDim Res2(1 To sRow, 1 To sCol2)
For j = 1 To sCol2
iKey = "Res2" & Rng(1, j).Value2
If Dic.exists(iKey) = False Then Dic.Add iKey, j
Next j
Set Rng = .Range(Ngay_Res3)
Set rngRes3 = Rng(1, 1).Offset(1)
sCol3 = Rng.Columns.Count
ReDim Res3(1 To sRow, 1 To sCol3)
For j = 1 To sCol2
iKey = "Res3" & Rng(1, j).Value2
If Dic.exists(iKey) = False Then Dic.Add iKey, j
Next j
Set Rng = Nothing
End With
With Sheets("STOCK")
eRow = .Range("A" & Rows.Count).End(xlUp).Row
sArr = .Range("A2:C" & eRow).Value
n = UBound(sArr)
For i = 1 To n
If sArr(i, 3) > 0 Then
iRow = Dic.Item(sArr(i, 1))
If iRow > 0 Then Res(iRow, 1) = Res(iRow, 1) + sArr(i, 3)
End If
Next i
End With
With Sheets("SODER")
eRow = .Range("A" & Rows.Count).End(xlUp).Row
sArr = .Range("A2:C" & eRow).Value
n = UBound(sArr)
For i = 1 To n
iRow = Dic.Item(sArr(i, 1))
Ngay = sArr(i, 2)
Ngay = CLng(DateSerial(Left(Ngay, 4), Mid(Ngay, 5, 2), Mid(Ngay, 7, 2)))
jCol = Dic.Item("Res2" & Ngay)
If iRow > 0 And jCol > 0 Then Res2(iRow, jCol) = Res2(iRow, jCol) + sArr(i, 3)
Next i
End With
With Sheets("PRODUCTION")
eRow = .Range("A" & Rows.Count).End(xlUp).Row
sArr = .Range("A2:D" & eRow).Value
n = UBound(sArr)
For i = 1 To n
iRow = Dic.Item(sArr(i, 1))
Ngay = sArr(i, 4)
Ngay = CLng(DateSerial(Mid(Ngay, 7, 4), Mid(Ngay, 1, 2), Mid(Ngay, 4, 2)))
jCol = Dic.Item("Res3" & Ngay)
If iRow > 0 And jCol > 0 Then Res3(iRow, jCol) = Res3(iRow, jCol) + CLng(sArr(i, 3))
Next i
End With
With Sheets("CHECK")
.Range("C3").Resize(sRow, 1).Value = Res
rngRes2.Resize(sRow, sCol2).Value = Res2
rngRes3.Resize(sRow, sCol3).Value = Res3
End With
Set Dic = Nothing: Set rngRes2 = Nothing: Set rngRes3 = Nothing
End Sub
