excel vba 运行速度慢

Posted 2023-03-25

For i = 1 To number
For j = 1 To 31

Sheets("ABS").Cells(i, j + 1).Value =
Workbooks(getfilename).Sheets(orgsheet).Cells(i * 15 - 9, 8 + j).Value + _
Workbooks(getfilename).Sheets(orgsheet).Cells(i * 15 + 3, 8 + j).Value

Next j
Next i

上面的代码运行时间很长，如果nubmer= 18，差不多8秒才能完成，有没有更快的写法？

参考技术A 1、使用application.screenupdate，先关闭屏幕更新，结束时打开；使用application.EnableEvents，先关闭事件的触发，结束时再打开2、楼上金融系统说的很好，使用SpecialCells选择方法，可以剔除许多不需要的数据3、尽量少使用单元格直接参与计算，多使用变量和数组变量，先将数据读入变量或数组变量，对变量进行运算4、将单元格区域分块，比如，可以先读取一列，复制给数组，处理完了，再将数组的值一次性赋值给其他单元格，然后再将下一列读到这个数组……5、尽量减少代码中的select、activate、等没什么用的动作，直接使用“.”点符号取值或赋值6、尽量使用with语句，减少对象的读取动作7、暂时想到这么多，……最重要的一点：优化算法，减少循环次数，这就得看你的具体操作是什么了……这都是我的经验啊，何况打了这么多字，楼主不但要采纳，还得加分啊~~~本回答被提问者采纳

Excel vba运行太慢怎么提速运行的快些？

模块1代码
Sub hf()
Dim rng, rng1 As Range
Application.ScreenUpdating = False

Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row).Interior.Color = xlNone
For Each rng1 In Sheet2.Range("a1:a" & Sheet2.Range("a10000").End(xlUp).Row)
For Each rng In Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row)
If InStr(rng.Value, rng1.Value) And rng1 <> "" Then
rng.Interior.Color = 10000
End If
Next
Next
Sheet3.Cells.ClearContents
Sheet3.Cells.Interior.Color = xlNone
For Each rng In Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row)
If rng.Interior.Color <> 10000 And rng <> "" Then
j = rng.Row
rng.Resize(1, 7).Copy Sheet3.Range("a" & j)
End If
Next

Application.ScreenUpdating = True
End Sub
----------------------------------------------------------------------------
Sub feg()

Sheet1.Visible = True
End Sub

模块2代码
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Count > 1 Then
Exit Sub
ElseIf Target = "" Then
Exit Sub
ElseIf Target.Column = 1 Then

Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row).Interior.Color = xlNone
For Each rng1 In Sheet2.Range("a1:a" & Sheet2.Range("a10000").End(xlUp).Row)
For Each rng In Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row)
If InStr(rng.Value, rng1.Value) And rng1 <> "" Then
rng.Interior.Color = 10000
End If
Next
Next
Sheet3.Cells.ClearContents
Sheet3.Cells.Interior.Color = xlNone
For Each rng In Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row)
If rng.Interior.Color <> 10000 And rng <> "" Then
j = rng.Row
rng.Resize(1, 7).Copy Sheet3.Range("a" & j)
End If
Next

End If

Application.ScreenUpdating = True
End Sub

各位大侠怎么优化速度会提上来。
在此拜谢~~

你这个算法确实太慢，双重循环反复在提取EXCEL表格数据，EXCEL提取数据是非常慢的，一般的思路是定义一个数组，一次性把表格的数据提取到数组里面，查询数组中的数据就非常快了。

另外，你的代码总是在设置单元格颜色，这个也很慢，而且没办法优化，建议数据增加一列，程序把计算结果填入这列，然后使用条件格式控制单元格的格式，这样优化就彻底了。

由于各段代码有类似性，我下面以模块1的代码块1位例子，给出使用数组进行优化例子，希望你能理解和举一反三。

优化后代码的文本如下，有可能排版会乱，建议结合上图阅读。

    Dim arr1, arr2, i, j \'定义两个数组

    arr1 = Sheet1.UsedRange.Resize(, 1) \'一次性提取表1数据A列

    arr2 = sheet2.UsedRange.Resize(, 1) \'一次性提取表2数据A列

    Sheet1.UsedRange.Resize(, 1).Interior.Color = xlNone \'所有已经使用空间的第一列

    For i = 1 To UBound(arr1) \'对表1A列所有数据进行检查

        If arr1(i, 1) <> "" Then \'如果它非空

            For j = 1 To UBound(arr2) \'查看是否包含表2A列的某一行

                If InStr(arr1(i, 1), arr2(j, 1)) Then

                    Sheet1.Cells(i, 1).Interior.Color = 10000 \'这个语句仍然影响速度

                    Exit For \'一旦标记就不再继续扫描表2

                End If

            Next j

        End If

    Next i

追问

谢谢解答，我这样写的代码实在太慢了，对VBA不是很会，请问下 我想实现这个效果 还有其他的写法吗，表一 是原数据，表2 输入关键字后 在表1有包含表2输入的关键字数据进行清除掉，在把表2 输入的关键字清除掉，表1有包含表2清除的关键字数据在恢复回来，在表三展示效果，表1 原始数据不动，5万行的数据，这样的怎么写速度才会快，麻烦指点下 非常感谢！



追答

你这个【再恢复】出来，理论上删除的东西是恢复不了的，除非开始删除的时候放一份到别的表存起来。
其它逻辑没有问题，使用数组你会发现速度快很多，几万行的数据秒级完成。

追问

Sheet3.Cells.ClearContents
Sheet3.Cells.Interior.Color = xlNone
For Each rng In Sheet1.Range("a1:a" & Sheet1.Range("a10000").End(xlUp).Row)
If rng.Interior.Color 10000 And rng "" Then
j = rng.Row
rng.Resize(1, 7).Copy Sheet3.Range("a" & j)
End If
Next

Application.ScreenUpdating = True
End Sub
下面这段代码 应该怎么用数组

追答

你这是把sheet1表A列有颜色的行复制到表3，由于检测颜色无法使用数组实现，所以现在就继续吃苦果了。无法优化颜色检测代码，可以需要写的内容写入数组，最后一次性写入表3，相当于节省一半的时间。如果之前不是设置颜色，而是存入某一列数里面，那么这里就可以彻底的优化得非常快速了。

数组换成写入的代码大概如下（没有环境调试，遇到语法小错误稍微思考试试修改）：

arr=sheet1.usedrange.resize(,7)
n=1
For i=1 to ubound(arr)
if arr(i,1)"" then
If sheet1.cells(i,1).Interior.Color =10000 Then
if ni then
for j=1 to 7: arr(n,j)=arr(i,j):next j
n=n+1
end if
end if
end if
Next i
n=n-1
if n>1 then
Sheet3.Cells.ClearContents
Sheet3.cells(1,1).resize(n,1)=arr
end if

追问

好的 谢谢了 非常感谢！

参考技术A 这么多字符串包含比较就这速度了。