VBA：Worksheet_Changeでのループとオフセット

Question

私は遅いうまく機能しているコードが、少しを持っていると私はそれをより効率的にする方法を知りたい

（答えで更新されたバージョンを探します） 。コードに2つのループが含まれているという事実が、考えられる原因の1つになる可能性があります。もし以下

全体のコードを見つけることができる：コードは、同じID（列1）を有するすべての隣接セルに対して同じ入力値（列13）に挿入され

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 

を。例えば、私は希望の場合は、入力ID002またはID003のいずれかでColumn13 3：私は値をunputたら

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

（2番目と最後の更新）

をありがとう！）。

そして、これが結果です：

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 

私はこの最後の更新から感謝何が、それはコードが軽く見せていたということです。しかし、それは以前のアップデートと比べてやや遅くなっています。

これまでに投稿したすべてのバージョンでタイマーを設定し、同じ条件でコードの実行速度をテストするために、同じIDに属する3行目のコードを13行目で実行しました。

私の初期コード：0.55秒。

最初の更新（For-Next out、Offset out & Array）：0.19秒。

2回目の更新（Do While out & Find）：0.20秒。

私は20秒の時間をこなすことができないので、私はコードがよりクリーンであるので、私はこのバージョンを使用すると思います。

ありがとうございました。

Answer 2

あなたは一度にすべての細胞にTarget.Valueを割り当てることができ、このループ

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.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

（初回更新）

私はあなたの提案でコードを再構築しました。

これが結果です：

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を配列に置き換えましたが、実際には何の違いもありませんでした。

2回目に行ってみましょう。

ありがとうございます！

Answer 5

whileループでは、おそらくfind関数を使用できます。

ここに私が意味するものの大まかなアイデアがあります。列A内のシートで

はVBEに入る9

0 
0 
0 
1 
1 
1 
2 
2 
2 

まで1行に次のように入れて、CTRL-Gを使用して、デバッグウィンドウを開き、次のように入力します

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

"1"の最初のインスタンスとして$ A $ 4が返されます

これ以上は何も同じではないことを検出したいので、これ自体はお勧めできません。

問題はありません（データがグループ化されていると仮定します）。

今VBEにこれを置く：

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

をを押すと、あなたが最後に出現のアドレスである$ A $ 6取得します入力して、我々は単にこのように、これを相殺することができます

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

と入力すると、次のセルのアドレス$ A $ 7が表示されます。つまり、フィードの内容と同じではない場合です。

うまくいけば、訴訟

最初の行は、検索設定としてあなたはかかわらず、一緒にこれらの両方が必要なのです。私は（@Danドノヒューのアイデアでコードを更新し

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