VBA：循環和偏移量Worksheet_Change

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 

該代碼是插入相同的輸入值（第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值時，它需要幾秒鐘以重新計算相鄰小區，所以我將理解任何建議，這將使這個代碼工作更快。

非常感謝！

Answer 1

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

我更新了@丹多諾霍的想法代碼（謝謝！）。

這是結果：

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秒，我覺得作爲代碼更乾淨，我將使用這個版本。

再次感謝。

Answer 2

沒有原因循環

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 

Answer 3

該解決方案避免了循環和使用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 4

（第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循環，這是不必要的，稍微改進了性能。其次，我將替換爲一個數組，但它並沒有真正的區別。

讓我們去第二輪，其他想法？

謝謝！

Answer 5

使用那些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