带有私有子的 VBA 代码处理时间太长

Question

因此，我有 1903 行代码，这些代码合并在三个与 Private Sub Worksheet_Change （ByVal target As Range）一起使用的函数中。它们都运行得很好，但由于是 1903 行，所以过程太长了。第一个是这样的：

If Target.Count = 1 Then
Dim Colr As Long, Txt As String

If Target.Address(0, 0) = "C9" Then
  Txt = "Please insert your purchase order number here"
End If

If Target.Address(0, 0) = "C53" Then
  Txt = "Please insert your purchase amount here"
End If

If Target.Address(0, 0) = "C97" Then
  Txt = "Please insert your purchase amount here"
End If

第二个是这样的：

If Target.Address = "$B$11" Then
    If Target.Value <> "" Then
        Sheets("Calculation sheet").Rows("9:15").EntireRow.Hidden = False
    Else
        Sheets("Calculation sheet").Rows("9:15").EntireRow.Hidden = True
    End If
End If
  
If Not Application.Intersect(Target, Me.Range("$B$11,$G$11")) Is Nothing Then

    ThisWorkbook.Worksheets("Annex 1").Rows(11).Hidden = _
      Len(Me.Range("$B$11").Value) = 0 Or Me.Range("$G$11").Value <> "Success"
      
End If

If Target.Address = "$B$12" Then
    If Target.Value <> "" Then
        Sheets("Calculation sheet").Rows("16:22").EntireRow.Hidden = False
    Else
        Sheets("Calculation sheet").Rows("16:22").EntireRow.Hidden = True
    End If
End If

If Not Application.Intersect(Target, Me.Range("$B$12,$G$12")) Is Nothing Then

    ThisWorkbook.Worksheets("Annex1").Rows(12).Hidden = _
      Len(Me.Range("$B$12").Value) = 0 Or Me.Range("$G$12").Value <> "Success"
      
End If

If Target.Address = "$B$13" Then
    If Target.Value <> "" Then
        Sheets("Calculation sheet").Rows("23:29").EntireRow.Hidden = False
    Else
        Sheets("Calculation sheet").Rows("23:29").EntireRow.Hidden = True
    End If
End If

If Not Application.Intersect(Target, Me.Range("$B$13,$G$13")) Is Nothing Then

    ThisWorkbook.Worksheets("Annex1").Rows(13).Hidden = _
      Len(Me.Range("$B$13").Value) = 0 Or Me.Range("$G$13").Value <> "Success"
      
End If

第三个是这样的：

If Target.Address = "$C$9" Then
    If Target.Value <> "" Then
        Sheets("Annex1").Rows("9").EntireRow.Hidden = False
    Else
        Sheets("Annex1").Rows("9").EntireRow.Hidden = True
    End If
End If

If Target.Address = "$C$10" Then
    If Target.Value <> "" Then
      Sheets("Annex1").Rows("10").EntireRow.Hidden = False
    Else
      Sheets("Annex1").Rows("10").EntireRow.Hidden = True
    End If
End If

If Target.Address = "$C$17" Then
    If Target.Value <> "" Then
        Sheets("Annex1").Rows("17").EntireRow.Hidden = False
    Else
        Sheets("Annex1").Rows("17").EntireRow.Hidden = True
    End If
End If

有没有办法缩短这个过程或者有解决方案吗？

Answer 1

类似这样的事情应该是您的目标 - 查看代码的重复部分并找出如何只编写每个部分一次...

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub 'only handling one-cell changes
    
    DoMessage Target
    HideShowRows Target
    
End Sub


Sub DoMessage(Target As Range)
    Dim txt As String
    Select Case Target.Address(False, False)
        Case "C9": txt = "Please insert your purchase order number here"
        Case "C53", "C97": txt = "Please insert your purchase amount here"
    End Select
    If Len(txt) > 0 Then
        'show message
    End If
End Sub


Sub HideShowRows(Target As Range)
    Const ROWS_PER_BLOCK As Long = 7
    Dim rwNum As Long, wb As Workbook
    
    Set wb = ThisWorkbook
    
    'Adjust B11:B50 to cover all rows of interest
    If Not Application.Intersect(Target, Me.Range("B11:B50")) Is Nothing Then
        rwNum = 9 + ((Target.Row - 11) * ROWS_PER_BLOCK) 'start row of block to hide/show
        wb.Sheets("Calculation sheet").Cells(rwNum, "A"). _
             Resize(ROWS_PER_BLOCK).EntireRow.Hidden = (Len(Target.Value) = 0)
    End If
    
    If Not Application.Intersect(Target, Me.Range("B11:B50,G11:G50")) Is Nothing Then
        With Target.EntireRow
            wb.Worksheets("Annex 1").rows(Target.Row).Hidden = _
                Len(.Columns("B").Value) = 0 Or .Columns("G").Value <> "Success"
        End With
    End If
    
End Sub