vba代码优化

w84322665

请各路大神帮忙看下以下VBA代码，能否优化下，经常卡死。

Sub 汇总()
Dim arr, brr(), SR$

Application.Calculation = 3
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False

Dim wb As Workbook
Dim Tqsj, sjhz, sh As Worksheet
Dim i, j, k, g As Integer
Dim km As String


Set Tqsj = Worksheets("提取数据-表")
Set sjhz = Worksheets("数据汇总")

j = sjhz.[A1048576].End(xlUp).Row + 1
sjhz.Range("A7:V" & j).ClearContents

For g = 9 To 400
    k = 9 '===============
    BU = Tqsj.Cells(g, 3)
    If BU <> "" Then
    Set sh = Worksheets(BU)
    arr = sh.UsedRange.Value
    ReDim brr(10 To UBound(arr), 1 To UBound(arr, 2))
    For i = 10 To UBound(arr)
        If arr(i, 7) <> 0 Then
            k = k + 1
            For j = 1 To UBound(arr, 2)
                brr(k, j) = arr(i, j)
            Next
        End If
    Next
    j = sjhz.[A1048576].End(xlUp).Row + 1
    sjhz.Range("B" & j).Resize(k, UBound(brr, 2)) = brr
    If k > 9 Then
    sjhz.Range("A" & j).Resize(k - 9) = BU
    End If
    End If

    Erase arr
    Erase brr

Next g

varytina

传附件看看

w84322665

varytina 发表于 2019-12-20 12:28
传附件看看

可以加你QQ？ 因为附件涉及到财务的数据，无法上传

varytina

w84322665 发表于 2019-12-25 15:06
可以加你QQ？ 因为附件涉及到财务的数据，无法上传

1420725850