程序太大，excel vba
任何想法如何把这个代码更小？ 这段代码是如何在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
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
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
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至19select案例Target.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的
在我看来，代码还没有优化，可能包括一些你可能想要消除的冗余。 这尤其是因为所有这些代码都驻留在Worksheet_Change事件中。 所以每当你改变表单上的任何单元格时，整个代码就会触发，需要很长时间才能运行。
如果你想继续，那么你可以将所有这些FOR封装成更小的Sub并从主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
您可以使用更多的逻辑来显着减less代码量：
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可以包含多个单元格（例如，当用户将内容粘贴到工作表中，或者select多个单元格，input值，然后按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