Code Sổ cái báo lỗi Out of memory khi tăng số lượng dòng tăng lên (1 người xem)

[chicpt]

[GPECODE=vb]Private Sub CN_Scai_Click()

Dim Tm, Kq(), i, j, X, TK
Dim Dic As Object
Dim Thg, SThg, Snam, SThg1, Snam1, Thg1, NoDK, CoDK
Dim SCai As Worksheet
Set SCai = Worksheets("SoCai")
TK = SCai.Cells(4, 3)
NoDK = SCai.Cells(3, 7)
CoDK = SCai.Cells(3, 8)
'=======Tao 1 tu dien de ghi nho danh sach cac chung tu va phong khi can cong tong theo chung tu
Set Dic = CreateObject("Scripting.Dictionary")
'Sap xep lai du lieu theo Thang => Ngay va So chung tu de trich loc theo thu tu hop ly nhat
With Sheet2 ' =========Sheets"Data" la Sheets chua du lieu goc can truy xuat va Trich loc
.Range(.Rows(4), .Rows(65536).End(4)).Sort Key1:=.Range("C5"), Order1:=1, _
Key2:=.Range("B5"), Order2:=1, Key3:=.Range("H5"), Order3:=1, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
'=============== Gan bien Tm bang toan bo du lieu de lam viec tren bien mang toc do cao hon
Tm = .Range(.[A5:AJ5], .[A500:AJ500].End(4))
End With
For i = 1 To UBound(Tm, 1)
'======== Neu Cot 32 Data = NKC thi lay va mang sang "SoCai "tat ca noi dung theo yeu cau
If Tm(i, 20) = TK Or Tm(i, 21) = TK Then
j = j + 1: X = X + 1
'========== Gan du lieu theo thu tu tuong ung cac Cot
ReDim Preserve Kq(1 To 8, 1 To X)
Kq(1, X) = Tm(i, 1)
Kq(2, X) = Tm(i, 8)
Kq(3, X) = Tm(i, 4)
Kq(4, X) = Tm(i, 33)
Kq(5, X) = "x"
If Tm(i, 20) = TK Then
Kq(6, X) = Tm(i, 21)
Kq(7, X) = Tm(i, 17)
SThg1 = SThg1 + Tm(i, 17)
Snam1 = Snam1 + Tm(i, 17)
ElseIf Tm(i, 21) = TK Then
Kq(6, X) = Tm(i, 20)
Kq(8, X) = Tm(i, 17)
SThg = SThg + Tm(i, 17)
Snam = Snam + Tm(i, 17)


End If


End If
'===============================Neu chua co thang thi dat thang bang thang bat dau
If Thg = "" And Thg1 = "" Then
Thg = Tm(i, 3)
Thg1 = Tm(i, 3)
'================================ Nguoc lai Neu het du lieu thi them dong cong thang va cong nam
ElseIf i = UBound(Tm, 1) Then
ReDim Preserve Kq(1 To 8, 1 To X + 2)
Kq(1, X + 1) = "<<>>" ' Gan chuoi vao vi tri
Kq(5, X + 1) = "C" & ChrW(7897) & "ng PS th" & ChrW(225) & "ng " & Thg ' Gan chuoi vao vi tri
Kq(7, X + 1) = SThg1 ' Gan Gia tri vao vi tri
Kq(8, X + 1) = SThg ' Gan Gia tri vao vi tri
Kq(1, X + 1) = "<<>>" ' Gan chuoi vao vi tri
Kq(5, X + 1) = "C" & ChrW(7897) & "ng PS n" & ChrW(259) & "m " ' Gan chuoi vao vi tri
Kq(7, X + 1) = Snam1 ' Gan Gia tri vao vi tri
Kq(8, X + 1) = Snam ' Gan Gia tri vao vi tri
Kq(1, X + 2) = "<<>>"
Kq(5, X + 2) = "So du cuoi n" & ChrW(259) & "m "
If NoDK + Snam1 > CoDK + Snam Then
Kq(7, X + 2) = NoDK + Snam1 - CoDK - Snam
Else
Kq(8, X + 2) = CoDK + Snam - NoDK - Snam1
End If
'=======================Neu sang thang moi thi them dong cong thang
ElseIf Thg <> Tm(i + 1, 3) Then
X = X + 1
ReDim Preserve Kq(1 To 8, 1 To X)
Kq(1, X) = "<<>>"
Kq(5, X) = "C" & ChrW(7897) & "ng PS th" & ChrW(225) & "ng " & Thg ' Gan dong chu Cong thang vao Cot 5 cua NKC
Kq(7, X) = SThg1 ' Cong theo thang Cot Phat sinh No
Kq(8, X) = SThg ' Cong theo thang Cot Phat sinh Co
Thg = Tm(i + 1, 3)
SThg1 = 0
SThg = 0
End If
Next ' Thuc hien cong viec tiep theo
' ================================= Xoa Nhat ky cu
Sheet20.[A9:H65536].ClearContents
'================================== Dien so lieu moi vao SOCAI
Sheet20.[A9].Resize(UBound(Kq, 2), UBound(Kq, 1)) = Application.Transpose(Kq)
Sheet20.[G4] = Application.Transpose(Snam1)
Sheet20.[H4] = Application.Transpose(Snam)


'Range("C9:C65000").Select
'Selection.NumberFormat = "mm/dd/yyyy"
Range("C9").Select
'===================================== Xoa cac bien
Erase Kq
Set Dic = Nothing
End Sub[/GPECODE]

Nhờ các Pro xem giúp mình với. Do dữ liệu lên tới 32500 dòng ,
Khi gán Tm = .Range(.[A5:AJ5], .[A500:AJ500].End(4)) thì chạy tốt
khi gán Tm = .Range(.[A5:AJ5], .[A25500:AJ25500].End(4)) thì Báo lỗi " Out of memory"
Do file nặng nên mình không gửi lên diễn đàn được . Rất mong sự chia sẻ

 

[Quang_Hải]

Nhờ các Pro xem giúp mình với. Do dữ liệu lên tới 32500 dòng ,
Khi gán Tm = .Range(.[A5:AJ5], .[A500:AJ500].End(4)) thì chạy tốt
khi gán Tm = .Range(.[A5:AJ5], .[A25500:AJ25500].End(4)) thì Báo lỗi " Out of memory"
Do file nặng nên mình không gửi lên diễn đàn được . Rất mong sự chia sẻ

Chắc là không ai đọc nổi code của bạn đâu. Mình cảm giác câu lệnh gán dữ liệu vào biến Tm không chính xác
Bạn thử thế này xem coi có giải quyêt vấn đề được hay không
Tm = .Range(.[A5], .[AJ65536].End(3)).Value

PS: Hình như mấy câu lệnh End(4) của bạn không đúng rồi, mình nghĩ là end(3) mới đúng
Thấy trong code mược cái thư viện Dictionary mà không thấy xài cái gì, rồi dùng Transpose cũng ngộ ngộ

 

[chicpt]

Cảm ơn A Hải nha, mình làm được rồi . Mình sửa lại theo A_Hải End(3) chạy ok luôn. Thank