Dạ . dữ liệu em rất lớn, có khi lên tới hơn 10000 dòng dữ liệu cơ ạ.
10 ngàn thì AD2:AD10000. Còn hơn là 1 triệu
Thử xem Code VBA củ chuối này.
Option Explicit
Sub TongSumIFs()
Dim i&, j&, Lr&, t&, k&, R&, Lr1&, d&
Dim Arr(), Res()
Dim Dic As Object
Dim Key, Temp
With Sheets("DATA")
Lr = .Cells(100000, 1).End(xlUp).Row
Arr = .Range("A4:AD" & Lr).Value
R = UBound(Arr)
End With
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To R, 1 To 1)
For i = 1 To R
If Arr(i, 9) <> Empty Then
Key = Arr(i, 9) & "#" & Arr(i, 23)
If Not Dic.Exists(Key) Then
t = t + 1: Dic.Add (Key), t
Res(t, 1) = Arr(i, 30)
Else
k = Dic.Item(Key)
Res(k, 1) = Res(k, 1) + Arr(i, 30)
End If
End If
Next i
With Sheets("THUC TE")
Lr1 = .Cells(100000, 1).End(xlUp).Row
For i = 5 To Lr1
If .Cells(i, 1) <> Empty And .Cells(i, 1) Like "CONGDOAN" & "*" Then
For j = 5 To 35
Temp = .Cells(i, 1) & "#" & .Cells(3, j)
If Dic.Exists(Temp) Then
d = Dic.Item(Temp)
.Cells(i, j) = Res(d, 1)
End If
Next j
End If
Next i
End With
Set Dic = Nothing
MsgBox "Done"
End SubDạ, anh sửa giúp em ạ, cột tên hàng lúc là CONGDOAN , lúc là XUONG hoặc BOPHAN... và khi chạy code kết quả cũ xóa đi thay kết quả mới vào (code TongSumIFs1 của anh chạy đúng), và em chỉ muốn ra kết quả chỗ vùng bôi vàng các phần khác công thức giữ nguyên ạ.
Nếu Các tên hàng (thành phần) ở cột A sheets Thuc Te ít (XUONG, BO PHAN, CONG ĐOAN=3= ít ) Thì Bạn thử thay dòng
If Arr1(i, 1) <> Empty And Arr1(i, 1) Like "CONGDOAN" & "*" Then If Arr1(i, 1) <> Empty And (Arr1(i, 1) Like "CONGDOAN" & "*" Or Arr1(i, 1) Like "XUONG" & "*" Or Arr1(i, 1) Like "BO PHAN" & "*") Then'Đây là lấy từng Cell trong bảng ấy, nếu lấy từng phần tử trong mảng (được tạo từ bảng ấy) thì bạn tự sửa nhé
......
If Arr(i,1)<> Emp ty then
For Z=1 to 100
If Arr(i,1)=.Range("X"&z) then TenHang=Arr(i,1)
next Z
For j = 5 To 35
Temp = TenHang & "#" & Arr1(1, j)
......Dạ vâng. Em cám ơn. Để em thử ạ
Dạ . Tên hàng của em chỉ có 3 mục chính(em thay công thức anh ok rồi).em đang dùng code TongSumIFs1 đang ok. Em đang mắc chỗ muốn kết quả ra vùng màu vàng (E5:AI25 và E32:AI45 , E52:E59...), Các vùng khác không bị mất công thức Mong anh giúp em đoạn này với ạ. Em cám ơn anh ạ
Dạ. Em có đọc và thử rùi. Em muốn dùng TongSumIFs1 để ghi lên vùng kết quả, em vẫn đang mắc sửa như nào để cho các vùng ngoài chỗ bôi vàng (E5:AI25 và E32:AI45 , E52:E59...), Không bị mất công thức. Mong anh giải đáp giúp em với. Em cám ơn ạ
Option Explicit
Sub test()
Dim lr&, i&, j&, k&, m&, n&, sum As Long
Dim grp1 As Range, grp2 As Range, grp3 As Range, grp4 As Range
Dim ngay, nhom, hang, data, rng, res()
With Sheets("DATA")
lr = .Cells(Rows.Count, "A").End(xlUp) 'xác dinh dong cuoi cung can cu vao cot A
data = .Range("I2:AD" & lr).Value ' gan du lieu trong DATA vao data
End With
With Sheets("THUC TE")
Set grp1 = .Range("A5:A" & .Range("A5").End(xlDown).Row) 'neu nhom hang 1 bat dau tu o A5
Set grp2 = .Range("A32:A" & .Range("A32").End(xlDown).Row) 'neu nhom hang 2 bat dau tu o A32
Set grp3 = .Range("A52:A" & .Range("A52").End(xlDown).Row) 'neu nhom hang 3 bat dau tu o A52
Set grp4 = .Range("A66:A" & .Range("A66").End(xlDown).Row) 'neu nhom hang 4 bat dau tu o A66
ngay = .Range("E3:AI3").Value ' vung tieu de ngay
nhom = Array(grp1, grp2, grp3, grp4) ' tap hop cua 4 nhom hang
For n = 0 To UBound(nhom) ' duyet qua tung nhom hang
rng = nhom(n).Value ' gan gia tri vao rng
ReDim res(1 To UBound(rng), 1 To UBound(ngay, 2))
For i = 1 To UBound(rng) ' duyet qua tung ten hang
For j = 1 To UBound(ngay, 2) ' duyet qua tung ngay
sum = 0
For m = 1 To UBound(data) ' duyet qua tung dong trong data
'neu thoa 2 dieu kien ten hang va ngay thi cong luy ke lai voi nhau
If data(m, 1) = rng(i, 1) And data(m, 15) = ngay(1, j) Then
sum = sum + data(m, 22)
res(i, j) = sum
End If
Next
Next
Next
nhom(n).Offset(, 4).Resize(UBound(res), UBound(res, 2)).Value = res ' dan ket qua vao sheet
Next
End With
End SubBạn chạy thử Modul 2 trong đó có Sub TongSumIFs (trong file đính kèm tôi đã gửi bạn)
Option Explicit
Sub TongSumIFs()
Dim i&, j&, Lr&, t&, k&, R&, Lr1&, d&, R1&, tt&
Dim Arr(), Res(), Arr1(), Res1()
Dim Dic As Object
Dim Key, Temp
With Sheets("DATA")
Lr = .Cells(100000, 1).End(xlUp).Row
Arr = .Range("A4:AD" & Lr).Value
R = UBound(Arr)
End With
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To R, 1 To 1)
For i = 1 To R
If Arr(i, 9) <> Empty Then
Key = Arr(i, 9) & "#" & Arr(i, 23)
If Not Dic.Exists(Key) Then
t = t + 1: Dic.Add (Key), t
Res(t, 1) = Arr(i, 30)
Else
k = Dic.Item(Key)
Res(k, 1) = Res(k, 1) + Arr(i, 30)
End If
End If
Next i
With Sheets("THUC TE")
Lr1 = .Cells(100000, 1).End(xlUp).Row
For i = 5 To Lr1
If .Cells(i, 1) <> Empty And .Cells(i, 1) Like "CONGDOAN" & "*" Then
For j = 5 To 35
Temp = .Cells(i, 1) & "#" & .Cells(3, j)
If Dic.Exists(Temp) Then
d = Dic.Item(Temp)
.Cells(i, j) = Res(d, 1)
End If
Next j
End If
Next i
End With
Set Dic = Nothing
MsgBox "Done"
End SubDạ vâng. Em cám ơn anh ạ
Dạ vâng. Em cám ơn anh đã hỗ trợ em nhiệt tình.
Code anh chạy ok rùi ạ, đúng ý em rùi ạ , cám ơn anh, anh còn ghi chú dễ hiểu ạ.
Góp vui . . .
Option Explicit
Option Compare Text
Sub XYZ()
Dim arr(), aNgay(), aHang(), res(), Dic As Object, key$, str$
Dim i&, r&, j&, sRow&, sCol&, fR&
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
arr = .Range("I3", .Range("AD" & Rows.Count).End(xlUp)).Value
End With
sRow = UBound(arr)
For i = 1 To sRow
If arr(i, 1) <> Empty Then
key = arr(i, 1) & "|" & arr(i, 15)
Dic.Item(key) = Dic.Item(key) + arr(i, 22)
End If
Next i
str = "T? l? ho?t ??ng" 'Ty le hoat dong
With Sheets("THUC TE")
aNgay = .Range("E3", .Range("AAA3").End(xlToLeft)).Value
sRow = .Range("A" & Rows.Count).End(xlUp).Row - 4 'Dong cuoi, loai bo 4 dong Tong
aHang = .Range("A1:A" & sRow + 1).Value
sCol = UBound(aNgay, 2)
aHang(4, 1) = str
For i = 4 To sRow
If aHang(i, 1) Like str Then
fR = i + 1
ReDim res(fR To sRow, 1 To sCol)
ElseIf fR > 0 Then
If aHang(i + 1, 1) = Empty Then
.Range("E" & fR).Resize(i - fR + 1, sCol) = res
fR = -9999
Else
For j = 1 To sCol
res(i, j) = Dic(aHang(i, 1) & "|" & aNgay(1, j))
Next j
End If
End If
Next i
End With
Set Dic = Nothing
End SubEm thử code anh, chạy tốt , em cám ơn anh ạ
