VBA: Loops и Смещение в 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) для всех соседних ячеек с тем же идентификатором (столбец 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

(второе и последнее обновление)

Я обновил код с идеей @Dan Донохью (в благодаря!).

И это результат:

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, которые относятся к идентичному идентификатору, чтобы проверить, насколько быстро код работает в тех же условиях.

Мой первоначальный код: 0,55 секунд.

1st update (For-Next out, Offset & Array in): 0.19 секунд.

2nd update (Do While & 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

(первое обновление)

Я переделал код с вашими предложениями.

Это результат:

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, который был лишним и немного улучшил производительность. Во-вторых, я заменил Offset, который искал идентификатор с массивом, но на самом деле это не имело никакого значения.

Пошлите второй раунд, любую другую идею?

Спасибо!

Answer 5

С помощью этих циклов вы можете использовать функцию поиска.

Вот приблизительное представление о том, что я имею в виду.

В листе в колонке А поместите в строке 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