VBA Worksheet_Change работает только для одной ячейки - PullRequest
1 голос
/ 17 марта 2020

Я бы хотел в предисловии сказать, что я новичок в VBA, так что, надеюсь, это легко исправить. Я пытаюсь заставить следующий код VBA работать для нескольких ячеек с формулами. В результате в ячейке есть побочное значение, которое пользователь может перезаписать, а затем снова посмотреть, удаляют ли они свое значение. Я могу заставить одну ячейку работать так, как я хочу, но вторая (и третья, и четвертая и т. Д. c.) Не работают. Как я могу повторить эту же строку кода, чтобы эффект повторялся в нескольких ячейках с разными формулами?

Рабочая:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)    
    With Target
      If .Address(False, False) = "F7" Then
        If IsEmpty(.Value) Then
          Application.EnableEvents = False
          .Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
          Application.EnableEvents = True
        End If
      End If
    End With    
End Sub

Моя попытка (верхняя часть работает, нижняя часть нет):

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  With Target
    If .Address(False, False) = "F7" Then
      If IsEmpty(.Value) Then
        Application.EnableEvents = False
        .Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
        Application.EnableEvents = True
      End If
    End If
  End With
End Sub

Private Sub Worksheet_Change1(ByVal Target As Excel.Range)
  With Target
    If .Address(False, False) = "F8" Then
      If IsEmpty(.Value) Then
        Application.EnableEvents = False
        .Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
        Application.EnableEvents = True
      End If
    End If
  End With
End Sub

Ответы [ 2 ]

1 голос
/ 17 марта 2020

Попробуйте это ...

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i&, j&, v, t
  v = Target.Value2
  If Not IsArray(v) Then t = v: ReDim v(1 To 1, 1 To 1): v(1, 1) = t
  Application.EnableEvents = False
  For i = 1 To UBound(v)
    For j = 1 To UBound(v, 2)
      If Len(v(i, j)) = 0 Then
        With Target(i, j)
            Select Case .Address(0, 0)
                Case "A1": .Formula = "=""Excel"""
                Case "A2": .Formula = "=""Hero"""
            End Select
        End With
      End If
    Next
  Next
  Application.EnableEvents = True
End Sub

Конечно, используйте мои формулы и диапазоны вместо моих.


Обновление

Выше хорошо работает, но это быстрее / лучше ...

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i&, v
  DoEvents
  ReDim v(1 To 3, 1 To 2)
  v(1, 1) = "A1": v(1, 2) = "=""This"""
  v(2, 1) = "A2": v(2, 2) = "=""Works"""
  v(3, 1) = "A2": v(3, 2) = "=""Great!"""
  Application.EnableEvents = False
  For i = 1 To UBound(v)
    With Range(v(i, 1))
      If Not Intersect(Target, .Cells) Is Nothing Then
        If Len(.Value2) = 0 Then
          .Formula = v(i, 2)
        End If
      End If
    End With
  Next
  Application.EnableEvents = True
End Sub

Оба вышеперечисленных метода работают для удаления одной ячейки, а также для очистки и удаления больших диапазонов, включая целые столбцы и целые строки, а второй метод особенно быстро во всех этих сценариях ios.

1 голос
/ 17 марта 2020

Вы можете сделать что-то вроде этого:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    'only handle single cells
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If IsError(Target.Value) Then Exit Sub  '<< edit: added
    'only handle empty cells
    If Len(Target.Value) > 0 Or Len(Target.Formula) > 0 Then Exit Sub

    On Error Goto haveError
    Application.EnableEvents = False
    Select Case Target.Address(False, False)
        Case "F7": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
        Case "F8": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
    End Select

haveError:
    'ensure events are re-enabled
    Application.EnableEvents = True
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...