Процедура слишком большая excel vba

Question

Любая идея, как уменьшить этот код? Этот код, как он не работает на VBA Как сделать здесь дополнительные процедуры?

Private Sub Worksheet_Change(ByVal Target As Range) 




For J = 17 To 19 
Select Case Target.Address 
    Case "$J$17" 
    If Not Intersect(Target, Range("J17:J19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$J$18" 
    If Not Intersect(Target, Range("J18:J18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$J$19" 
    If Not Intersect(Target, Range("J19:J19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 
Next 

другие для

For N = 17 To 19 
Select Case Target.Address 
    Case "$N$17" 
    If Not Intersect(Target, Range("N17:N19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$N$18" 
    If Not Intersect(Target, Range("N18:N18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$N$19" 
    If Not Intersect(Target, Range("N19:N19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 
Next 

других ДЛЯ

For R = 17 To 19 
Select Case Target.Address 

    Case "$R$17" 
    If Not Intersect(Target, Range("R17:R19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$R$18" 
    If Not Intersect(Target, Range("R18:R18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$R$19" 
    If Not Intersect(Target, Range("R19:R19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 
Next 

других ДЛЯ

For V = 17 To 19 
Select Case Target.Address 

    Case "$V$17" 
    If Not Intersect(Target, Range("V17:V19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$V$18" 
    If Not Intersect(Target, Range("V18:V18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$V$19" 
    If Not Intersect(Target, Range("V19:V19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 
Next 

другого При Z = 17 К 19 Select Case Тарга et.Address

Case "$Z$17" 
    If Not Intersect(Target, Range("Z17:Z19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$Z$18" 
    If Not Intersect(Target, Range("Z18:Z18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$Z$19" 
    If Not Intersect(Target, Range("Z19:Z19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 
Next 

И так далее

For AH = 16 To 16 
Select Case Target.Address 
    Case "$AH$16" 
    If Not Intersect(Target, Range("AH16:AJ16")) Is Nothing Then 
    Target.Offset(2, 0) = Date 
    End If 
End Select 
Next 





End Sub 

Есть ± 160 Для

Answer 1

Мне кажется, что код еще не оптимизирован и может включать в себя некоторую избыточность вы могли бы хотеть, чтобы устранить первый. Это особенно связано с тем, что весь этот код находится на событии Worksheet_Change. Поэтому каждый раз, когда вы меняете любую ячейку на этом листе, весь код загорается и занимает много времени.

По-прежнему, если вы хотите продолжить, вы можете просто инкапсулировать все эти FOR в меньшие Sub s и называть их один за другим с основного Sub. Вот короткий пример, чтобы продемонстрировать идею:

Private Sub Worksheet_Change(ByVal Target As Range) 

For J = 17 To 19 
Select Case Target.Address 
    Case "$J$17" 
    If Not Intersect(Target, Range("J17:J19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$J$18" 
    If Not Intersect(Target, Range("J18:J18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$J$19" 
    If Not Intersect(Target, Range("J19:J19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 

Call MoreChecks1(Target) 
Call MoreChecks2(Target) 
Call MoreChecks3(Target) 

Next 


Public Sub MoreChecks1(ByVal Target As Range) 

For N = 17 To 19 
Select Case Target.Address 
    Case "$N$17" 
    If Not Intersect(Target, Range("N17:N19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$N$18" 
    If Not Intersect(Target, Range("N18:N18")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 

    Case "$N$19" 
    If Not Intersect(Target, Range("N19:N19")) Is Nothing Then 
     Target.Offset(0, 1) = Date 
    End If 
End Select 
Next 

End Sub 

Answer 2

Вы можете уменьшить объем кода значительно используя немного больше логики:

Private Sub Worksheet_Change(ByVal Target As Range) 

    Dim c As Range, tg As Range 

    Set c = Target.Cells(1) 'in case of multiple cells updated... 

    Set tg = Me.Range("J17:J19") 'first range to check for updates 

    Do While tg(1).Column <= 26 'Col Z 
     If Not Application.Intersect(c, tg) Is Nothing Then 
      c.Offset(0, 1) = Date 
      Exit Do 
     End If 
     Set tg = tg.Offset(0, 4) 'move tg over 4 cols to the right 
    Loop 

End Sub 

Вы также должны знать, что Target может содержать несколько ячеек (например, например, когда пользователь вставляет содержимое в лист или выбирает несколько ячеек, вводит значение, а затем нажимает Ctrl + Enter), поэтому вам может понадобиться учитывать это.

В моем примере выше я просто использую первую ячейку.

несколько иной подход:

Private Sub Worksheet_Change(ByVal Target As Range) 

    Dim c As Range, tg As Range, rw As Long 

    Set c = Target.Cells(1) 'in case of multiple cells updated... 

    Set tg = Me.Range("J:J,N:N,R:R,V:V,Z:Z") 'columns to check for updates 

    If Not Application.Intersect(c, tg) Is Nothing Then 
     rw = c.Row 
     'check valid row: add more checks as required 
     If (rw >= 17 And rw <= 19) Or _ 
      (rw >= 307 And rw <= 309) Then 

      On Error Goto haveError 
      Application.EnableEvents = False 
      c.Offset(0, 1) = Date 
      Application.EnableEvents = True 

     End If 'tracked row 
    End If  'tracked column 

    Exit Sub 

haveError: 
    'always make sure this is turned back on... 
    Application.EnableEvents = True 

End Sub