vba使用效率太低，有没有办法提高效率

lofty0623 · 发表于 2024-6-28 12:43

主要是其中的HideEmptyRows函数，涉及大概至少300行数据，使用效率太低了，有没有办法进行提高效率

Sub completeedit()
Dim found1 As Boolean, found2 As Boolean, found3 As Boolean
Dim ws As Worksheet
Dim cell As Range
found1 = False
found2 = False
found3 = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each cell In Sheet7.Range("F7:F37")
If InStr(1, cell.Value, "确权", vbTextCompare) > 0 Then
found1 = True
ElseIf InStr(1, cell.Value, "确权外", vbTextCompare) > 0 Then
found2 = True
ElseIf InStr(1, cell.Value, "其他", vbTextCompare) > 0 Then
found3 = True
End If
Next cell
If found1 Then HideEmptyRows Sheet3, "D6:D35", "D39:D68"
If found2 Then HideEmptyRows Sheet4, "D6:D35", "D39:D68"
If found3 Then HideEmptyRows Sheet5, "D5:D25"
HideEmptyRows Sheet6, "D6:D300"
HideEmptyRows Sheet7, "G7:G37"
HideNegativeRows Sheet2, "E8:E11"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub HideEmptyRows(ws As Worksheet, ParamArray ranges() As Variant)
Dim rng As Range
Dim r As Variant
For Each r In ranges
For Each rng In ws.Range(r)
If rng.Value = "" Then
rng.EntireRow.Hidden = True
End If
Next rng
Next r
End Sub
Sub HideNegativeRows(ws As Worksheet, rngAddress As String)
Dim rng As Range
Dim cell As Range
For Each cell In ws.Range(rngAddress)
If cell.Value <= 0 Then
cell.EntireRow.Hidden = True
End If
Next cell
End Sub

复制代码

边缘码农 · 发表于 2024-6-28 13:36

使用Union方法将需要隐藏的行联合成一个单元格区域，然后一次性隐藏。

跨越时空 · 发表于 2024-6-28 13:59

上传个附件吧

ykcbf1100 · 发表于 2024-6-28 17:03

不是VBA效率低，你才300行数据，3万行数据也不会慢哪里去。关键在于你搞了2个自定义过程，效率低的问题所在吧。没有附件也说不清楚，也许只要不多的代码就能达到目的。

wang-way · 发表于 2024-6-30 01:56

你那个两个过程效率太低了判断空行可以使用工作表函数 counta，隐藏操作之前可以把所有符合隐藏条件的行 union 组合在一起，最后只需要隐藏一次。循环操作工作表是比较慢的

yes_cn · 发表于 2024-7-5 15:49

Sub completeedit()
Dim ws As Worksheet
Dim cell As Range, hideRanges As Range
Dim found(1 To 3) As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' 优化 Sheet7 搜索逻辑
For Each cell In Sheet7.Range("F7:F37")
Select Case True
Case InStr(1, cell.Value, "确权", vbTextCompare) > 0: found(1) = True
Case InStr(1, cell.Value, "确权外", vbTextCompare) > 0: found(2) = True
Case InStr(1, cell.Value, "其他", vbTextCompare) > 0: found(3) = True
End Select
If found(1) And found(2) And found(3) Then Exit For
Next cell
' 隐藏相应工作表的空行
If found(1) Then HideRowsBasedOnCondition Sheet3, "D6:D35,D39:D68", "=""", True
If found(2) Then HideRowsBasedOnCondition Sheet4, "D6:D35,D39:D68", "=""", True
If found(3) Then HideRowsBasedOnCondition Sheet5, "D5:D25", "=""", True
HideRowsBasedOnCondition Sheet6, "D6:D300", "=""", True
HideRowsBasedOnCondition Sheet7, "G7:G37", "=""", True
HideRowsBasedOnCondition Sheet2, "E8:E11", "<=0", False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub HideRowsBasedOnCondition(ws As Worksheet, rangeAddress As String, condition As String, useCountA As Boolean)
Dim rng As Range, cell As Range, hideRanges As Range
For Each rng In ws.Range(rangeAddress)
If useCountA Then
If Application.WorksheetFunction.CountA(rng) = 0 Then
If hideRanges Is Nothing Then
Set hideRanges = rng.EntireRow
Else
Set hideRanges = Union(hideRanges, rng.EntireRow)
End If
End If
Else
If Evaluate(rng.Address & condition) Then
If hideRanges Is Nothing Then
Set hideRanges = rng.EntireRow
Else
Set hideRanges = Union(hideRanges, rng.EntireRow)
End If
End If
End If
Next rng
If Not hideRanges Is Nothing Then hideRanges.Hidden = True
End Sub

复制代码

Lost_in_Star · 发表于 2024-7-6 16:48

Sub completeedit()
Dim found1 As Boolean, found2 As Boolean, found3 As Boolean
Dim cell As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Reset flags
found1 = False
found2 = False
found3 = False
' Check the required range and set flags accordingly
For Each cell In Sheet7.Range("F7:F37")
If Not found1 And InStr(1, cell.Value, "确权", vbTextCompare) > 0 Then
found1 = True
ElseIf Not found2 And InStr(1, cell.Value, "确权外", vbTextCompare) > 0 Then
found2 = True
ElseIf Not found3 And InStr(1, cell.Value, "其他", vbTextCompare) > 0 Then
found3 = True
End If
' Exit the loop early if all flags are set
If found1 And found2 And found3 Then Exit For
Next cell
' Apply row hiding based on flags
If found1 Then HideEmptyRows Sheet3, "D6:D35", "D39:D68"
If found2 Then HideEmptyRows Sheet4, "D6:D35", "D39:D68"
If found3 Then HideEmptyRows Sheet5, "D5:D25"
HideEmptyRows Sheet6, "D6:D300"
HideEmptyRows Sheet7, "G7:G37"
HideNegativeRows Sheet2, "E8:E11"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub HideEmptyRows(ws As Worksheet, ParamArray ranges() As Variant)
Dim rng As Range
Dim r As Variant
Dim cell As Range
Dim fullRange As Range
' Combine all ranges into one
For Each r In ranges
If fullRange Is Nothing Then
Set fullRange = ws.Range(r)
Else
Set fullRange = Union(fullRange, ws.Range(r))
End If
Next r
' Iterate over the entire range and hide rows
If Not fullRange Is Nothing Then
For Each cell In fullRange
If cell.Value = "" Then
cell.EntireRow.Hidden = True
End If
Next cell
End If
End Sub
Sub HideNegativeRows(ws As Worksheet, rngAddress As String)
Dim cell As Range
Dim fullRange As Range
' Get the specified range
Set fullRange = ws.Range(rngAddress)
' Iterate over the range and hide rows with non-positive values
If Not fullRange Is Nothing Then
For Each cell In fullRange
If cell.Value <= 0 Then
cell.EntireRow.Hidden = True
End If
Next cell
End If
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] vba使用效率太低，有没有办法提高效率