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

Posted 2023-03-25

模块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 这么多字符串包含比较就这速度了。