Question

（在答案中找到更新版本）

我的代码运行良好但有点慢，我想知道如何提高效率。代码包含两个循环的事实可能是其中一个原因。

您可以在下面找到整个代码：

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Columns.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Me.Range("TABLE[COLUMN]")) Is Nothing Then
    Application.ScreenUpdating = False
    Dim rngCell As Range, urg As Range, drg As Range, u As Integer, d As Integer
    d = 0
    u = 0
    Set urg = Target.Cells(1, 1)
    Set drg = Target.Cells(Target.Count, 1)
    Do While drg.Offset(d, -13) = drg.Offset(d + 1, -13)
        d = d + 1
    Loop
    Do While urg.Offset(u, -13) = urg.Offset(u - 1, -13)
        u = u - 1
    Loop
    For Each rngCell In Me.Range(Target.Offset(u, 0), Target.Offset(d, 0))
        Application.EnableEvents = False
        rngCell.Value = Target.Value
        Application.EnableEvents = True
    Next
    Application.ScreenUpdating = True
End If
End Sub

代码为具有相同ID的所有相邻单元插入相同的输入值（第13列）（第1列）。例如，如果我在ID002或ID003中为Column13输入3：

Column1 Column2 Column3... Column13       Column13
ID001   1       1          1          >   1
ID002   2       2          2          >   3
ID002   3       3          2          >   3
ID003   4       4          4          >   4

一旦我输出了值，重新计算相邻单元格需要花费几秒钟的时间，所以我将不胜感激任何能使这段代码更快运行的建议。

非常感谢！

Answer 1

这个循环没有理由

Target.Value

您可以一次将Application.EnableEvents = False Me.Range(Target.Offset(u, 0), Target.Offset(d, 0)).Value = Target.Cells(1).Value Application.EnableEvents = True分配给所有单元格。

{{1}}

Answer 2

此解决方案避免了循环并使用了Excel表（ListObject excel对象）

的优点

试试这段代码：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lobTrg As ListObject
Dim aIDs As Variant
Dim bPos As Byte

    If Target.Columns.CountLarge > 1 Then Exit Sub

    Rem Application Setting - OFF
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Rem Set List Object
    Set lobTrg = Me.ListObjects("TABLE")

    Rem Work with the ListObject Methods & Properties
    With lobTrg

        Rem Validate Target Range vs ListObject Field [COLUMN]
        If Not (Intersect(Target, .ListColumns("COLUMN").DataBodyRange) Is Nothing) Then

            Rem Remove Active Filters from the ListObject
            If Not (.AutoFilter Is Nothing) Then .Range.AutoFilter

            Rem Set Array with ID's Affected by the Changes in Field [COLUMN]
            aIDs = Target.Offset(, -13).Value2
            aIDs = WorksheetFunction.Transpose(aIDs)

            Rem Filter ListObject using the ID's Array
            bPos = .ListColumns("COLUMN").Index - 13
            .Range.AutoFilter Field:=bPos, Criteria1:=aIDs, Operator:=xlFilterValues

            Rem Update Field [COLUMN] value for all the ID's
            .ListColumns("COLUMN").DataBodyRange _
                .SpecialCells(xlCellTypeVisible).Value = Target.Cells(1).Value2

            Rem Removes Filters from List Object
            .Range.AutoFilter

    End If: End With

    Rem Application Setting - ON
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

建议阅读以下页面以深入了解所使用的资源：

ListObject Members (Excel)，With Statement，

Answer 3

（第一次更新）

我根据您的建议重新编写了代码。

结果如下：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim u As Long, d As Long
Dim id As Variant
If Target.Columns.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Me.Range("TABLE[COLUMN]")) Is Nothing Then
    Application.ScreenUpdating = False
    id = Me.Range("TABLE[ID]").Value
    u = Target.Row - 1
    d = Target.Row + Target.Count - 2
    Do While id(u, 1) = id(u - 1, 1)
        u = u - 1
    Loop
    Do While id(d, 1) = id(d + 1, 1)
        d = d + 1
    Loop
    Application.EnableEvents = False
    Me.Range(Target.Cells(1).Offset(u - Target.Row + 1, 0), Target.Cells(1).Offset(d - Target.Row + 1, 0)).Value = Target.Cells(1).Value
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End If
End Sub

我按块应用了这些更改。首先，我删除了For-Next循环，这是不必要的，并略微提高了性能。其次，我用一个数组替换了正在寻找ID的Offset，但它并没有什么区别。

让我们进行第二轮，任何其他想法？

谢谢！

Answer 4

（第二次和最后一次更新）

我用@Dan Donoghue的想法更新了代码（谢谢！）。

这就是结果：

For-Next

我从上次更新中感谢到它使代码看起来更轻松。但是，与之前的更新相比，它的工作速度稍慢。

我在目前为止发布的所有版本中设置了一个计时器，并在第13列中运行了3行代码，这些代码属于相同的ID，以测试代码在相同条件下的执行速度。

我的初始代码：0.55秒。

第一次更新（Offset退出，Array退出＆Do While in）：0.19秒。

第二次更新（Find out＆amp; {{1}} in）：0.20秒。

由于我无法击败20秒的时间，我想我会使用这个版本，因为代码更干净。

再次感谢你。

Answer 5

使用while循环，你可以使用find函数。

这是我的意思的粗略概念。

在A栏的工作表中，将第1行中的以下内容放到9

进入VBE并使用CTRL-G启动调试窗口并输入以下内容：

?range("A1:A9").Find(1).address

它将返回$ 4 $作为＆＃34; 1＆＃34;

的第一个实例

现在这本身对你没有好处，因为你想要发现什么时候它不再等于什么。

没问题（假设您的数据已分组）。

现在将其放入VBE：

?range("A1:A9").Findprevious.Address

当你按Enter键时，你将获得$ A $ 6，这是最后一次出现的地址，我们可以这样简单地抵消：

?range("A1:A9").Findprevious.offset(1,0).Address

你将得到下一个小区的$ 7 $地址，即它不再等于你输入的内容。

希望您可以申请删除其他循环。

虽然第一行设置搜索，但您确实需要这两者：

?range("A1:A9").Find(1).address
?range("A1:A9").Findprevious.offset(1,0).Address

VBA：Worksheet_Change中的循环和偏移量

5 个答案: