Giúp: Codes cập nhật dữ liệu chạy chậm quá

[tedaynui]

Cháo các bạn,
Mình có 2 Sheet DATA và THU : Sheet DATA là danh sách học sinh; Sheet THU chứa phiếu thu tiền của học sinh. Một học sinh có thể đóng tiền nhiều lần. Mình muốn số tiền thu được trong sheet THU tổng hợp lại vô Sheet DATA. Mình dùng codes sau vẫn ra kết quả nhưng chậm quá. Nếu số lượng trong Sheet THU lên cả chục nghìn dòng thì chắc nó đơ ra quá.

Sub CapNhat()
Dim rData As Long, rThu As Long, i As Long, k As Long, l As Long
Dim MSHS As String
Dim ArrData, ArrThu
rData = S2.Range("A65536").End(xlUp).Row
rThu = S3.Range("A65536").End(xlUp).Row
ReDim ArrData(1 To rData, 1 To 15)
ArrThu = S3.Range("A5:V" & rThu)
For i = 4 To rData
    MSHS = S2.Cells(i, 1)
    For l = 8 To 22
        For k = 1 To rThu - 4
            If ArrThu(k, 4) = MSHS Then
                If Len(ArrThu(k, l)) > 0 Then
                    ArrData(i - 3, l - 7) = ArrData(i - 3, l - 7) + ArrThu(k, l)
                End If
            End If
        Next k
    Next l
Next i
S2.Range("J4:X" & rData) = ArrData
Erase ArrData, ArrThu
End Sub

Mình nghĩ hoài nhưng không tìm thuật toán nào hiệu quả. Các bạn cải tiến giúp. Xin cảm ơn!

TDN

 

[ThuNghi]

Cháo các bạn,
Mình có 2 Sheet DATA và THU : Sheet DATA là danh sách học sinh; Sheet THU chứa phiếu thu tiền của học sinh. Một học sinh có thể đóng tiền nhiều lần. Mình muốn số tiền thu được trong sheet THU tổng hợp lại vô Sheet DATA. Mình dùng codes sau vẫn ra kết quả nhưng chậm quá. Nếu số lượng trong Sheet THU lên cả chục nghìn dòng thì chắc nó đơ ra quá.Mình nghĩ hoài nhưng không tìm thuật toán nào hiệu quả. Các bạn cải tiến giúp. Xin cảm ơn!

TDN

Phước xem lại for i có OK chưa, theo mình nếu MSHS=MSHS mới xét đến các
1/ Xét theo Data (MSHS)
2/ Xét theo sh Thu pah62n MSHS
3/ Nếu MSHS=MSHS
4/ Lúc đó mới gán cát cột mục lục.

Sub CapNhat()
With Application
  .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Dim rData As Long, rThu As Long, i As Long, k As Long, l As Long
Dim MSHS As String
Dim ArrData, ArrThu, ArrMs()
rData = S2.Range("A65536").End(xlUp).Row
rThu = S3.Range("A65536").End(xlUp).Row
ReDim ArrData(1 To rData, 1 To 15)
ArrThu = S3.Range("A5:V" & rThu).Value
With S2
  ArrMs = .Range("A4:A" & rData).Value
End With
For i = 1 To UBound(ArrMs)
  MSHS = ArrMs(i, 1)
  For k = 1 To rThu - 4
    If ArrThu(k, 4) = MSHS Then
      For l = 8 To 22
        ArrData(i - 3, l - 7) = ArrData(i - 3, l - 7) + ArrThu(k, l)
      Next l
    End If
  Next k
Next i
S2.Range("J4:X" & rData) = ArrData
Erase ArrData, ArrThu, ArrMs()
With Application
  .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With

End Sub

Chưa test hết, do mới đi đám cưới về. Với những yêu câu trên thì code không chậm đâu.
Sáng mai mình sẽ hoàn thiện.
Nếu phần thu mỗi HS chỉ PS 1 lần ở sh THU thì mình thêm dàong exit for cụ thệ như sau

Sub CapNhat()
With Application
  .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Dim rData As Long, rThu As Long, i As Long, k As Long, l As Long
Dim MSHS As String
Dim ArrData, ArrThu, ArrMs()
rData = S2.Range("A65536").End(xlUp).Row
rThu = S3.Range("A65536").End(xlUp).Row
ReDim ArrData(1 To rData, 1 To 15)
ArrThu = S3.Range("A5:V" & rThu).Value
With S2
  ArrMs = .Range("A4:A" & rData).Value
End With
For i = 1 To UBound(ArrMs)
  MSHS = ArrMs(i, 1)
  For k = 1 To rThu - 4
    If ArrThu(k, 4) = MSHS Then
      For l = 8 To 22
        'ArrData(i - 3, l - 7) = ArrData(i - 3, l - 7) + ArrThu(k, l)'
        ArrData(i - 3, l - 7) = ArrThu(k, l)
      Next l
      Exit For
    End If
  Next k
Next i
S2.Range("J4:X" & rData) = ArrData
Erase ArrData, ArrThu, ArrMs()
With Application
  .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub

Và mình không cần gì đến

Option Base 1

Vì đã khai array(1 to ...,...)

 

[nghiaphuc]

Cháo các bạn,
Mình có 2 Sheet DATA và THU : Sheet DATA là danh sách học sinh; Sheet THU chứa phiếu thu tiền của học sinh. Một học sinh có thể đóng tiền nhiều lần. Mình muốn số tiền thu được trong sheet THU tổng hợp lại vô Sheet DATA. Mình dùng codes sau vẫn ra kết quả nhưng chậm quá.
Nếu số lượng trong Sheet THU lên cả chục nghìn dòng thì chắc nó đơ ra quá. Mình nghĩ hoài nhưng không tìm thuật toán nào hiệu quả. Các bạn cải tiến giúp. Xin cảm ơn!

TDN

Mình xử lý theo hướng khác: Sử dụng hàm trong Excel để tính, sau đó copy và dán giá trị (mục đích là để giảm kích thước file). Cụ thể như sau:
- Đầu tiên, nhập công thức cho ô J1 trên sheet DATA là =COUNT(THU!A:A) để đếm số phiếu thu.
- Kế tiếp, sử dụng code này để cập nhật:

Sub CapNhat()
    Dim Vung As Range
    Set Vung = Range("J4:X" & [A65536].End(xlUp).Row)
    Vung.FormulaR1C1 = "=SUMIF(OFFSET(THU!R5C4,0,0,R1C10,1),RC1,OFFSET(THU!R5C7,0,COLUMNS(RC10:RC),R1C10,1))"
    Vung.Copy
    Vung.PasteSpecial xlPasteValues
End Sub

Với cách này, kích thước file nặng hơn cách của bạn (lý do là ở những mục không thu, cách của bạn trả về ô rỗng, cách của mình trả về 0. Có lẽ cái này khắc phục được). Tuy nhiên, mình nhận thấy cách giải quyết này có 2 ưu điểm hơn hẳn cách của bạn:
1. Code rất ngắn gọn.
2. Thời gian xử lý nhanh hơn cách của bạn. Mình đã test thử, với CSDL của bạn, code của bạn chạy mất 16-17s, code của mình chạy mất 4-5s.
Bạn tham khảo trong file nhé. Trong code, mình có thêm một số câu lệnh (có chú thích) để test thời gian chạy của code.

 

[tedaynui]

@ To NghiaPhuc
Cảm ơn bạn, mình đã test thử ở sheet THU với 5500 dòng, cách của bạn mất 11 giây như vậy là hiệu quả hơn cách mình rất nhiều.
Kết quả có số 0 khắc phục cũng không khó, chỉ cần thêm

Vung.Replace What:="0", Replacement:="", MatchCase:=True, LookAt:=xlWhole

và không phải chịu lệ thuộc ô [J1] bằng cách đặt 2 Name động :
MSHS = OFFSET(INDIRECT("THU!D5"),0,0,COUNTA(THU!$A:$A),1)
Rng = OFFSET(INDIRECT("THU!"&ADDRESS(5,COLUMN()-2,4)),0,0,COUNTA(THU!$A:$A),1)

Vậy Codes sẽ là

Dim rData As Long
rData = [A65536].End(xlUp).Row
With Range("J4:X" & rData)
        .Value = "=SUMIF(MSHS,$A5,Rng)"
        .Value = .Value
        .Replace What:="0", Replacement:="", MatchCase:=True, LookAt:=xlWhole
End With

Cảm ơn bạn đã giúp đỡ!
TDN

 

[ThuNghi]

@ To NghiaPhuc
Cảm ơn bạn, mình đã test thử ở sheet THU với 5500 dòng, cách của bạn mất 11 giây như vậy là hiệu quả hơn cách mình rất nhiều.
Kết quả có số 0 khắc phục cũng không khó, chỉ cần thêm

Vung.Replace What:="0", Replacement:="", MatchCase:=True, LookAt:=xlWhole

và không phải chịu lệ thuộc ô [J1] bằng cách đặt 2 Name động :
MSHS = OFFSET(INDIRECT("THU!D5"),0,0,COUNTA(THU!$A:$A),1)
Rng = OFFSET(INDIRECT("THU!"&ADDRESS(5,COLUMN()-2,4)),0,0,COUNTA(THU!$A:$A),1)

Đã dùng VBA mà lại còn tiếc name nữa, không cần thiết phải vậy, dùng code đặt luôn

MSHS = OFFSET(INDIRECT("THU!D5"),0,0,COUNTA(THU!$A:$A),1)

Hôm qua chưa test hết và sai ở i-3
Phước xem lại code sau

Option Explicit
Dim TG1, TG2
Sub CapNhatArr()
TG1 = Now()
Dim endR As Long, i As Long, k As Long, l As Long
Dim MSHS As String
Dim ArrData, ArrThu, ArrMsData(), ArrMsThu()
With Sheets("Data")
  endR = .Range("A65536").End(xlUp).Row
  ArrMsData = .Range("A4:A" & endR).Value
End With
ReDim ArrData(1 To endR - 3, 1 To 15)
With Sheets("Thu")
  endR = .Range("A65536").End(xlUp).Row
  ArrMsThu = .Range("D5:D" & endR).Value
  ArrThu = .Range("H5:V" & endR).Value
End With
For i = 1 To UBound(ArrMsData) 'xet theo lan luot Data'
  MSHS = ArrMsData(i, 1)
  For k = 1 To UBound(ArrMsThu) 'xet theo lan luot ArrMsThu'
    If ArrMsThu(k, 1) = MSHS Then 'neu OK thi lay theo ArrMsThu'
      For l = 1 To 15
        ArrData(i, l) = ArrData(i, l) + ArrThu(k, l)
      Next l
    End If
  Next k
Next i
'Gan vao'
With Sheets("Data")
  .Range("J4").Resize(i - 1, 15) = ArrData
End With
Erase ArrData, ArrThu, ArrMsData(), ArrMsThu()
TG2 = Now() 'Thoi gian ket thuc chay
MsgBox TG1 & vbCr & TG2 & vbCr & Format(TG2 - TG1, "HH:mm:ss") 'Ket qua
End Sub

Và Phước kiểm tra thử tốc độ so với sumif thử, có cả các code trong file.
Yêu cầu này nếu dùng thêm Dictionanry thì nhanh hơn nữa và cũng tiện để update thêm các Sh THU01, THU02... vào data.
Code dùng Dic

Option Explicit
Dim TG1, TG2
Sub CapNhatArr2()
TG1 = Now()
Dim endR As Long, i As Long, k As Long, l As Long, dongso As Long
Dim MSHS As String
Dim ArrData, ArrThu, ArrMsData(), ArrMsThu()
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  endR = .Range("A65536").End(xlUp).Row
  ArrMsData = .Range("A4:A" & endR).Value
End With
ReDim ArrData(1 To endR - 3, 1 To 15)
With Sheets("Thu")
  endR = .Range("A65536").End(xlUp).Row
  ArrMsThu = .Range("D5:D" & endR).Value
  ArrThu = .Range("H5:V" & endR).Value
End With
For i = 1 To UBound(ArrMsData) 'Gan vao Dic MSHS cua Data'
  If Not Dic.Exists(ArrMsData(i, 1)) Then
    Dic.Add ArrMsData(i, 1), i
  End If
Next i
For k = 1 To UBound(ArrMsThu) 'xet theo lan luot ArrMsThu'
  MSHS = ArrMsThu(k, 1)
  If Dic.Exists(MSHS) Then
    dongso = Dic.Item(MSHS)
    For l = 1 To 15
        ArrData(dongso, l) = ArrData(dongso, l) + ArrThu(k, l)
    Next l
  End If
Next k
''Gan vao'
With Sheets("Data")
  .Range("J4").Resize(UBound(ArrMsData), 15) = ArrData
End With
Erase ArrData, ArrThu, ArrMsData(), ArrMsThu()
Set Dic = Nothing
TG2 = Now() 'Thoi gian ket thuc chay
MsgBox TG1 & vbCr & TG2 & vbCr & Format(TG2 - TG1, "HH:mm:ss") 'Ket qua
End Sub

 

[tedaynui]

@ To anhThuNghi
Cảm ơn anh rất nhiều, Codes chạy vô cùng hiệu quả. Nhanh vô cùng, hẹn ngày xin hậu tạ.

TDN