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

 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到19 选择Case 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>

Answer 1

在我看来，代码尚未优化，可能包含一些您可能希望首先消除的冗余。这尤其是因为所有这些代码都驻留在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

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

程序太大excel vba

2 个答案: