Worksheet Change Filling & Emptying

[CasualDabbler]

Need the following 2 items please
Item 1
If a cell in a range (D4:D2000) has a value entered, the cell at Target.Offset(0, 5).Value = "09:00" and subsequent values "17:00", "09:00" etc
Sheet is a work in progress and may have other columns inserted, so can the solution factor easily changing target ranges.
I.e. I set the initial target "MonOpen" and the rest flow from that cell
Target.Offset(0, 5).Value = "09:00"
Target.Offset(0, +1).Value = "17:00" etc

Item 2
If a cell in a range (D4:D2000) has its value cleared I need to clear the corresponding adjacent range. As per above sheet is WIP, looking to set the start of the range and just enter a width value

Thanks

 

[JEC]

Create a variable with your initial target column

n = 5
Target.Offset(0, n).Value = "09:00"
Target.Offset(0, n + 1).Value = "17:00"

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter an ID in column D and press the RETURN key.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("D4:D2000")) Is Nothing Then Exit Sub
    Dim lCol As Long, x As Long
    lCol = Cells(3, Columns.Count).End(xlToLeft).Column
    If Target <> "" Then
        For x = 9 To lCol Step 2
            Cells(Target.Row, x).Resize(, 2) = Array("09:00", "17:00")
        Next x
    Else
        Cells(Target.Row, 9).Resize(, lCol - 4).ClearContents
    End If
    Application.ScreenUpdating = True
End Sub

 

[CasualDabbler]

Create a variable with your initial target column

n = 5
Target.Offset(0, n).Value = "09:00"
Target.Offset(0, n + 1).Value = "17:00"

Thanks

 

[Snakehips]

If Column D remains the 'Target' column regardless of any column insertions then maybe tweak @mumps code as below?

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("D4:D2000")) Is Nothing Then Exit Sub
    Dim lCol As Long, x As Long, fcol As Long
      
    lCol = Cells(3, Columns.Count).End(xlToLeft).Column
    fcol = WorksheetFunction.Match("MonOpen", Range(Cells(3, 1), Cells(3, lCol)))
    If Target <> "" Then
        For x = fcol To lCol Step 2
            Cells(Target.Row, x).Resize(, 2) = Array("09:00", "17:00")
        Next x
    Else
        Cells(Target.Row, fcol).Resize(, lCol - 4).ClearContents
    End If
    Application.ScreenUpdating = True
End Sub

*If it is only ever 14 columns of opening times then fCol = sCol + 13 and there wont be any issue if there is other data in columns to right of lCol?

 

[CasualDabbler]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter an ID in column D and press the RETURN key.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("D4:D2000")) Is Nothing Then Exit Sub
    Dim lCol As Long, x As Long
    lCol = Cells(3, Columns.Count).End(xlToLeft).Column
    If Target <> "" Then
        For x = 9 To lCol Step 2
            Cells(Target.Row, x).Resize(, 2) = Array("09:00", "17:00")
        Next x
    Else
        Cells(Target.Row, 9).Resize(, lCol - 4).ClearContents
    End If
    Application.ScreenUpdating = True
End Sub

Hi Mumps, this is pretty close to what I'm after - Thanks
Where do I set the start column. I now need to offset from column D by 9
My array is not a clean 09:00, 17:00. The Sat & Sun are 00:00. I'm happy to hard code all 14 values if that helps
Your code is filling to the end of the row. I need a fixed length range for the on change input (14 cells) and a separate fixed length range for when the cell in col d is cleared (x cells)

(Sheet is WIP -Apologies my initial post was not clear enough on that) - so need to be able to set the start points until I've got all the columns in place I need
Input range needs to have a start offset I can set, then 14 values
Clear range needs to have a start offset I can set & a width I can set (2 Variables that determine the Range)

 

[CasualDabbler]

I've "butchered" the code to get to the following, which seems to work ok. Any thoughts?

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("D4:D2000")) Is Nothing Then Exit Sub
    Dim FCol As Long
    Dim ClrSt As Long, ClrLen As Long
    
    FCol = 13
    
    ClrSt = 5
    ClrLen = 22
    
    If Target <> "" Then
            Cells(Target.Row, FCol).Resize(, 14) = Array("09:00", "17:00", "09:00", "17:00", "09:00", "17:00", "09:00", "17:00", "09:00", "17:00", "00:00", "00:00", "00:00", "00:00")
    Else
        Cells(Target.Row, ClrSt).Resize(, ClrLen).ClearContents
    End If
    Application.ScreenUpdating = True
End Sub

 

[mumps]

If it works, go with it.