VBA：循环和偏移量Worksheet_Change

-1

（查找答案更新版本）VBA：循环和偏移量Worksheet_Change

我有一个代码，这是工作的很好，但有点慢，我想知道如何使它更有效。代码包含两个循环的事实可能是其中一个可能的原因。

下面你可以找到整个代码：

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

该代码是插入相同的输入值（第13列）的所有具有相同ID（第1列）的相邻小区。例如，如果我将在输入一个3 Column13任ID002或ID003：

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

一旦我unput值时，它需要几秒钟以重新计算相邻小区，所以我将理解任何建议，这将使这个代码工作更快。

非常感谢！

来源

2016-11-23 Senzar

的'Offset'电话和工作表的访问可能是什么杀了你的表现 - 你需要的所有值拉成一个阵列，并与工作。 – Comintern

此外，你可以在年底'rngCell设置的值。value = Me.Range（Target.Offset（u，0），Target.Offset（d，0））.value'，使rngCell的深度等于du –

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

我更新了@丹多诺霍的想法代码（谢谢！）。

这是结果：

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 
    Dim u As Long, d As Long 
    u = Range("TABLE[ID]").Find(Range("TABLE[ID]").Cells(Target.Row - 1, 1)).Row 
    d = Range("TABLE[ID]").Find(Range("TABLE[ID]").Cells(Target.Row + Target.Count - 2, 1), searchdirection:=xlPrevious).Row 
    Application.EnableEvents = False 
    Me.Range(Target.Cells(1).Offset(u - Target.Row, 0), Target.Cells(1).Offset(d - Target.Row, 0)).Value = Target.Cells(1).Value 
    Application.EnableEvents = True 
End If 
End Sub

我从这个最后的更新明白的是，它使代码更亮。但是，与之前的更新相比，它的运行速度稍慢。

我在所有我张贴到目前为止版本设置一个计时器和我跑的代码为在塔13 3行属于相同ID测试代码在相同条件下如何快速执行。

我的初始代码：0.55秒。

1st update（For-Next out，Offset out & Array in）：0.19秒。

2nd update（Do While out & Find in）：0.20秒。

既然不能击败时间20秒，我觉得作为代码更干净，我将使用这个版本。

再次感谢。

来源

2016-11-25 11:56:53 Senzar

理论的完美应用，整洁简洁:)。很高兴为你工作。 –

没有原因循环

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

您可以分配Target.Value的所有单元格一次。

Application.EnableEvents = False 
Me.Range(Target.Offset(u, 0), Target.Offset(d, 0)).Value = Target.Cells(1).Value 
Application.EnableEvents = True

来源

2016-11-23 19:57:16

建议用Target.Cells替换Target.Value （1）.Value'复制原始OP的代码正在做的事情。如果目标范围有多个单元格，并且ID的范围比目标范围的单元格数量更多，则[列]中的一些单元格将填充“＃N/A”。 – EEM

感谢初始建议和随之而来的更正！ – Senzar

该解决方案避免了循环和使用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,

来源

2016-11-23 21:28:49 EEM

在Mac OS中运行代码时，我遇到了使用ListObjects的不佳体验。此外，它对我来说意味着一个全新的逻辑，但我非常感谢你的帮助和努力，非常感谢@EMM – Senzar

（第1次更新）

我重建了您的建议的代码。

这是结果：

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循环，这是不必要的，稍微改进了性能。其次，我将替换为一个数组，但它并没有真正的区别。

让我们去第二轮，其他想法？

谢谢！

来源

2016-11-24 16:33:13 Senzar

-1

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

下面是我的意思的粗略概念。

在列A的片材放置在第1行以下下降至9

进入所述VBE和使用CTRL-G调出调试窗口和输入以下内容：

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

它将返回$ A $ 4作为“1”的第一个实例

现在这本身对你来说并不好，因为你想要检测它不再等于什么。

没问题（假设你的数据是分组的）。

现在把这个进入VBE：

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

当你按回车键，你会得到$ A $ 6，其最后一次出现的地址，我们可以简单地抵消这种像这样：

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

，你将得到下一个单元格的地址$ A $ 7，即当它不再等于你所馈入的地址时。

希望有一些东西可以应用于删除其他的欢声笑语。

你确实需要这两个在一起，虽然作为第一行设置了搜索：

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

来源

2016-11-24 22:12:45

VBA：循环和偏移量Worksheet_Change

回答

相关问题