VBA очистить ячейку C, если я очищаю ячейку B

Question

Я новичок в VBA и последние несколько дней пытаюсь заставить это работать. У меня 2 столбца.

B-student C -date

Я хочу, чтобы ученик входил и помещал свои инициалы в столбец B, а затем заполнял дату в столбце C в этой строке.

Теперь, если я удалю инициалы учеников, я хочу, чтобы он очистил ячейку C также для этой строки.

Вот мой код

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Set wb = Workbooks("Training")
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
Dim StaffRange As Range
Set StaffRange = ws.Range("B5:B40")
Dim StaffTime As Range

' If they put in initials in StaffRange then proceed
If Not Intersect(Target, StaffRange) Is Nothing Then
Set StaffTime = ws.Range("C" & Target.Row)
If StaffTime.Value <> "" Then Exit Sub 'if there is already a date then exit
StaffTime.Value = Now     ' put in the date time
    
'now if they clear StaffRange then clear StaffTime
ElseIf Intersect(Target, StaffRange) Is Nothing Then
Set StaffTime = ws.Range("C" & Target.Row)
StaffTime.ClearContents     ' make blank

End If

End Sub

Спасибо за любую помощь.

Answer 1

Вы можете это сделать:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim b As Range, c As Range, rng As Range
    'updates in range of interest?
    Set rng = Application.Intersect(Me.Range("B5:B40"), Target)
    If rng Is Nothing Then Exit Sub 'nothing to process...
    
    For Each b In rng.Cells
        Set c = b.Offset(0, 1)
        If Len(b.Value) > 0 Then
            If Len(c.Value) = 0 Then c.Value = Now 'value entered: add time
        Else
            c.ClearContents                        'value cleared: clear time
        End If
    Next b
    
End Sub

Answer 2

У меня заработало. Спасибо вам обоим за ваш код. Я учился на обоих и придумал следующее.

Если это можно очистить, я был бы признателен за любые указатели.

Еще раз спасибо

Private Sub Worksheet_Change(ByVal Target As Range)

Dim b As Range, c As Range, d As Range, e As Range, rngb As Range, rngd As Range
    'updates in range of interest?
Set rngb = Application.Intersect(Me.Range("B5:B40"), Target)
Set rngd = Application.Intersect(Me.Range("D5:D40"), Target)

If Not rngb Is Nothing Then
For Each b In rngb.Cells
    Set c = b.Offset(0, 1)
    If Len(b.Value) > 0 Then
        If Len(c.Value) = 0 Then c.Value = Now 'value entered: add time
    Else
        c.ClearContents                        'value cleared: clear time
    End If
Next b
End If

If Not rngd Is Nothing Then
For Each d In rngd.Cells
    Set e = d.Offset(0, 1)
    If Len(d.Value) > 0 Then
        If Len(e.Value) = 0 Then e.Value = Now 'value entered: add time
    Else
        e.ClearContents                        'value cleared: clear time
    End If
Next d
End If

End Sub

Answer 3

Чтобы решить вашу проблему, просто измените ссылки с .Value = "" на .clear.

Также вам нужно добавить ссылку на лист, с которым вы работаете, иначе ваша ссылка на Range может "запутать" макрос.

Пояснение

Dim wb As Workbook: Set wb = Workbooks(ThisWorkbook.Name)  ' defines the workbook you are working in. You could change "ThisWorkbook" to the actual workbook name, but note that any changes to the workbook name (such as auto recover) will require you to modify this variable.
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' defines the worksheet within the workbook defined above. 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim StaffRange As Range
    Dim StaffTime As Range
    Dim TrainerRange As Range
    Dim TrainerTime As Range
    Dim wb As Workbook: Set wb = Workbooks(ThisWorkbook.Name) 
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    
    Set StaffRange = ws.Range("B5:B40")
    Set TrainerRange = ws.Range("D5:D40")
    
    ' If they put in initials in StaffRange then procede with entering the date stamp
    If Not Intersect(Target, StaffRange) Is Nothing Then
    Set StaffTime = ws.Range("C" & Target.Row)
    If StaffTime.Value <> "" Then Exit Sub 'if there is already a date in field do not update and exit
    StaffTime.Value = Now     ' put in the date time
    
    ' now if they clear StaffRange then clear StaffTime
    ' cell cleared
    ElseIf Intersect(Target, StaffRange) Is Nothing Then
    Set StaffTime = ws.Range("C" & Target.Row)
    ' If StaffTime.Value = "" Then Exit Sub    ' if it is already clear exit
    StaffTime.clear     ' make blank
    
    ' If they put in initials in TrainerRange then procede with entering the date stamp
    ElseIf Not Intersect(Target, TrainerRange) Is Nothing Then
    Set TrainerTime = ws.Range("E" & Target.Row)
    If TrainerTime.Value <> "" Then Exit Sub
    TrainerTime.Value = Now
    
    ' now if they clear TrainerRange then clear TrainerTime
    ' cell cleared
    ElseIf Intersect(Target, TrainerRange) Is Nothing Then
    clearing
    Set StaffTime = ws.Range("E" & Target.Row)
    ' If StaffTime.Value = "" Then Exit Sub    ' if it is already clear exit
    StaffTime.clear     ' make blank
    
    End If
    
End Sub