Giảm dung lượng file VBA

Chia sẻ bởi:hands

★★★★★

‹ code VBA đưa hình lên User form Không nhập được số thập phân trong... ›

Quảng cáo

Em chào mọi người,
em có 1 file theo dõi kho có code vba, nhưng nặng quá, chạy chậm và hay bị treo máy
Mọi người có cách nào xử lý giúp em được không ạ?
Em cảm ơn!

Bạn tham khảo:
Code trong moude của sheet Tổng:

Option Explicit

Private Sub Worksheet_Activate()
    BinhTinh Me
End Sub

Thêm 1 module nữa rồi đưa code sau vào:

Option Explicit

Public Sub BinhTinh(ByVal sheetTotal As Worksheet)

Dim dict As Object
    Dim sheetDataLot As Worksheet
    Dim dataLot() As Variant, key As Variant
    Dim strTong As String
    Dim i As Long, j As Long, lastRow As Long

strTong = "T" & ChrW(7893) & "ng" '<-- Tên sheet Tổng

On Error GoTo End_

Set sheetDataLot = ThisWorkbook.Worksheets("datalot")
    Set sheetTotal = ThisWorkbook.Worksheets(strTong)
    Set dict = CreateObject("Scripting.Dictionary")

lastRow = sheetDataLot.Cells(Rows.Count, "D").End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "Khong co gi!", vbCritical + vbOKOnly, "Xin cam on"
        Exit Sub
    End If
    dataLot = sheetDataLot.Range("D2:G" & lastRow).Value
    For i = 1 To UBound(dataLot, 1)
        If Not dict.exists(dataLot(i, 1)) Then
            dict.Add dataLot(i, 1), Array(dataLot(i, 3), dataLot(i, 4))
        End If
    Next i

lastRow = sheetTotal.Cells(Rows.Count, "G").End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "Khong co gi!", vbCritical + vbOKOnly, "Xin cam on"
        Exit Sub
    End If

Dim arrG, arrJ, arrK, arrL, arrM, arrGK, arrT, sumU
    Dim arrP() As Variant, arrQ() As Variant
    Dim total As Double

ReDim arrP(2 To lastRow), arrQ(2 To lastRow)

arrG = sheetTotal.Range("G2:G" & lastRow).Value
    arrJ = sheetTotal.Range("J2:J" & lastRow).Value
    arrK = sheetTotal.Range("K2:K" & lastRow).Value
    arrL = sheetTotal.Range("L2:L" & lastRow).Value
    arrGK = sheetTotal.Range("G2:K" & lastRow).Value
    sumU = sheetTotal.Range("U2:U" & lastRow).Value
    arrT = sheetTotal.Range("T2:T" & lastRow).Value

ReDim arrM(1 To lastRow - 1, 1 To 1)

For i = 1 To lastRow

key = sheetTotal.Range("O" & i + 1).Value
        If dict.exists(key) Then
            arrP(i) = dict(key)(0)
            arrQ(i) = dict(key)(1)
        End If

If i = 2 Then
            arrM(i - 1, 1) = arrJ(i, 1)
        Else
            If arrG(i, 1) = arrG(i - 1, 1) Then
                arrM(i - 1, 1) = arrM(i - 2, 1) + arrJ(i, 1) + arrK(i, 1) - arrL(i, 1)
            Else
                arrM(i - 1, 1) = arrJ(i, 1)
            End If
        End If

total = 0
        For j = LBound(arrGK, 1) To UBound(arrGK, 1)
            If arrT(j, 1) = arrT(i, 1) And arrG(j, 1) = arrG(i, 1) Then
                total = total + arrGK(j, 2) + arrGK(j, 3) - arrGK(j, 4)
            End If
        Next j
        sumU(i, 1) = total

Next i

sheetTotal.Range("U2:U" & lastRow).Value = sumU
    sheetTotal.Range("P2:P" & lastRow).Value = arrP
    sheetTotal.Range("Q2:Q" & lastRow).Value = arrQ
    sheetTotal.Range("M2:M" & lastRow).Value = arrM

End_:
    Application.EnableEvents = True

End Sub