VBA:循环和偏移量Worksheet_Change
(查找答案更新版本)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值时,它需要几秒钟以重新计算相邻小区,所以我将理解任何建议,这将使这个代码工作更快。
非常感谢!
(第二次和最后一次更新)
我更新了@丹多诺霍的想法代码(谢谢!)。
这是结果:
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秒,我觉得作为代码更干净,我将使用这个版本。
再次感谢。
理论的完美应用,整洁简洁:)。很高兴为你工作。 –
没有原因循环
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
该解决方案避免了循环和使用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
推荐阅读以下页面,以获得更深了解所用资源:
在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循环,这是不必要的,稍微改进了性能。其次,我将替换为一个数组,但它并没有真正的区别。
让我们去第二轮,其他想法?
谢谢!
使用那些while while循环,可以使用find函数。
下面是我的意思的粗略概念。
在列A的片材放置在第1行以下下降至9
0
0
0
1
1
1
2
2
2
进入所述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
的'Offset'电话和工作表的访问可能是什么杀了你的表现 - 你需要的所有值拉成一个阵列,并与工作。 – Comintern
此外,你可以在年底'rngCell设置的值。value = Me.Range(Target.Offset(u,0),Target.Offset(d,0)).value',使rngCell的深度等于du –