Add or clear values of alternate rows in a column range based on another cell's value

Question

I am looking for a way where i select a month from a drop down list containing months (JAN, FEB, MAR etc) in the sheet "Summary" which will then update the sheet "Equipment" cells F7:AJ7 with the dates for that month with cells F8:AJ8 containing the day (Sat, Sun, Mon) for their respective dates (=IF(F7="","",TEXT(F7,"ddd")).

Im trying to achieve clearing the column starting below "FRI" (Range("F9:F")) which contains the value 10 (All values are 10 but because I don't want it clearing anything else below the whole printable area I am specifying it to clear only those containing 10 & the rows are delete able where not required or can be added if anything additional. For that reason I am also making the range as "F9:F".

Vice Versa due to month selection, the Fridays move around. So those which were previously cleared as Fridays should get their values back as 10. Each equipment in this excel is entered every alternate row. So in a column it goes as 10 Blank 10 Blank etc.

This is what i got so far :

Here I have the alternate rows sorted out but only I need it to do the work on those cells with heading "Fri"

Sub Test()
    Application.ScreenUpdating = False
    Dim bottomA As Integer
    
    Dim bottomB As Integer
    Dim bottomC As Integer
    Dim bottomD As Integer
    Dim bottomE As Integer
      
    bottomA = Range("F" & Rows.Count).End(xlUp).Row
    
    bottomB = Range("M" & Rows.Count).End(xlUp).Row
    bottomC = Range("T" & Rows.Count).End(xlUp).Row
    bottomD = Range("AA" & Rows.Count).End(xlUp).Row
    bottomE = Range("AH" & Rows.Count).End(xlUp).Row
    
    Dim rng As Range
    
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Range
    
    For Each rng In Range("F9:F" & bottomA)
        rng.Value = Replace(rng, 10#, "")
    Next rng
    'Application.ScreenUpdating = True
       
    For Each rng1 In Range("M9:M" & bottomB)
        rng1.Value = Replace(rng1, 10#, "")
    Next rng1
    'Application.ScreenUpdating = True
    
    For Each rng2 In Range("T9:T" & bottomC)
        rng2.Value = Replace(rng2, 10#, "")
    Next rng2
    'Application.ScreenUpdating = True
    
    For Each rng3 In Range("AA9:AA" & bottomD)
        rng3.Value = Replace(rng3, 10#, "")
    Next rng3
    'Application.ScreenUpdating = True
    
    For Each rng4 In Range("AH9:AH" & bottomE)
        rng4.Value = Replace(rng4, 10#, "")
    Next rng4
    'Application.ScreenUpdating = True
    
End Sub

or this might be close to the solution ?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range

    ' Exit if multiple cells updated at once
    If Target.CountLarge > 1 Then Exit Sub

    ' See if cell is updated in watched range
    If (Not Intersect(Target, Range("F8").Value = "Fri") Is Nothing) And (Target.Value <> "") Then      
        Application.EnableEvents = False
        ' Loop through each cell in other range
        For Each cell In.    Range("F9:F300")
            ' See if it matches and clear value
            If cell.Value = Target.Value Then cell.ClearContents
        Next cell
        Application.EnableEvents = True
    End If
End Sub

Conditional Formatting is used to highlight those with FRI as orange & Those values below 10 are highlighted as red.

This is the code i am running for the drop down list :

On Error Resume Next

         

Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
     

' ******* Disable the below 2 lines if you are typing the whole sheet *******

' .Locked = True 'ActiveSheet.Protect Password:="123"

'*******************************************************************

End With


If Target.Validation.Type = 3 Then


    Target.Validation.InCellDropdown = False
    cancel = True


    xStr = Target.Validation.Formula1
    xStr = Right(xStr, Len(xStr) - 1)
    
    If xStr = "" Then Exit Sub
    
    With xCombox
        .Visible = True
        .Left = Target.Left
        .Top = Target.Top
        .Width = Target.Width + 5
        .Height = Target.Height + 5
        .ListFillRange = xStr
        If .ListFillRange = "" Then
            xArr = Split(xStr, ",")
            Me.Tempcombo.List = xArr
          
        End If

        .LinkedCell = Target.Address
    End With

    xCombox.Activate
    Me.Tempcombo.DropDown
            Me.Tempcombo.SelStart = 0

Me.Tempcombo.SelLength = Len(Me.Tempcombo.Value)

' The below line is to unprotect the sheet

    ActiveSheet.Unprotect
       
End If

End Sub

Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

Select Case KeyCode
    Case 9
        Application.ActiveCell.Offset(0, 1).Activate
        
    Case 13
        Application.ActiveCell.Offset(1, 0).Activate
        
End Select

End Sub

Answer 1

A Drop-Down Worksheet_Change

• On a manual change in (drop-down) cell F1 of the worksheet Summary, it will replace all cells which are equal to 10, only in columns with the header Fri (in row 8 starting with column F) of the worksheet Equipment with an Empty (mimicking ClearContents).

• Disabling events is not necessary unless you have an event code in the worksheet Equipment when you would apply it only to the line drg.Replace dSearch, Empty, xlWhole, the only line that writes to the mentioned worksheet.

Sheet Module (Summary in Parentheses)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ClearFridayTens Target
End Sub

Standard Module e.g. Module1 (alternatively to the same sheet module)

Option Explicit

Sub ClearFridayTens(ByVal Target As Range)
    Const ProcName As String = "ClearFridayTens"
    On Error GoTo ClearError

    ' Source
    Const sCellAddress As String = "F1"
    ' Destination
    Const dName As String = "Equipment"
    Const dhrgAddress As String = "F8:AJ8" '
    Const dhrgString As String = "Fri"
    Const dSearch As Long = 10
    
    ' Source
    Dim sws As Worksheet: Set sws = Target.Worksheet
    Dim sCell As Range: Set sCell = Intersect(sws.Range(sCellAddress), Target)
    If sCell Is Nothing Then Exit Sub ' no change
    
    ' Destination
    Dim dws As Worksheet: Set dws = Target.Worksheet.Parent.Worksheets(dName)
    Dim dhrg As Range: Set dhrg = dws.Range(dhrgAddress) ' Header Range
    Dim dlCell As Range
    Set dlCell = dhrg.Resize(dws.Rows.Count - dhrg.Row + 1) _
        .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    Dim drCount As Long: drCount = dlCell.Row - dhrg.Row + 1 ' Table Rows Count
    If drCount < 2 Then Exit Sub ' no data or only headers
    
    Dim dtrg As Range: Set dtrg = dhrg.Resize(drCount) ' Table Range
    'Debug.Print dtrg.Address
    Dim dcCount As Long: dcCount = dtrg.Columns.Count
    
    Dim drg As Range ' Replace Range ('10')
    Dim dhCell As Range ' Header Cell ('Fri')
    
    ' Find headers ('Fri').
    Set dhCell = dhrg.Find(dhrgString, dhrg.Cells(dcCount), xlValues, xlWhole)
    If Not dhCell Is Nothing Then ' Header Cell
        Dim dhFirstAddress As String: dhFirstAddress = dhCell.Address
        Do
            'Debug.Print dhCell.Address
            If drg Is Nothing Then
                Set drg = dhCell.Resize(drCount - 1).Offset(1)
            Else
                Set drg = Union(drg, dhCell.Resize(drCount - 1).Offset(1))
            End If
            Set dhCell = dhrg.FindNext(dhCell)
        Loop Until dhCell.Address = dhFirstAddress
    End If
    
    If Not drg Is Nothing Then
        drg.Replace dSearch, Empty, xlWhole
        MsgBox "Tens cleared.", vbInformation, ProcName
    Else
        MsgBox "No headers containing '" & dhrgString & "' found.", _
            vbCritical, ProcName
    End If
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub