Personnel/ appointment tracker

[landshark22]

Hi folks,

I was trying to see if anyone can help me with the folowing:
Currently, I have a monthly tracker that is color coded.
There is a row D 10 that is linked to A 5 which updates row D with dates

Underneath I track personnel and their appointments. I am trying to insert a code or something to delete the row with appointments and shift columns D-AX and below to the left with row D ( dates)

 

[NoSparks]

It appears you're asking pretty much the same as in February and June of last year.
Here's what I would try based on the file you previously linked to.

Remove the formula from D10
Copy A5 and paste as value into D10

Put this sub in the sheet module

Private Sub Worksheet_Calculate()
    If Range("A5") <> Range("D10") Then
        Call ShiftDataLeft
    End If
End Sub

Put this sub into a standard code module

Sub ShiftDataLeft()
    
    Dim WS As Worksheet
    Dim rng As Range
    Dim dateRng As Range
    Dim dataRng As Range
    Dim firstCopyCol As Long
    Dim arr
    
Set WS = ThisWorkbook.Sheets("Troop to Task")
Set dateRng = WS.Range("D10:AX10")
Set dataRng = WS.Range("D11:AX79")

' find column of A5
For Each rng In dateRng
    If rng.Value = Range("A5").Value Then
        firstCopyCol = rng.Column
        Exit For
    End If
Next rng

' check date exists
If firstCopyCol = 0 Then
    MsgBox "Date not found"
    Exit Sub
End If

With Application
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

' shift data
With dataRng
    arr = .Offset(, firstCopyCol - 4).Resize(, 47 - firstCopyCol + 4).Value
    .ClearContents
    .Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End With

dateRng.Cells(1) = WS.Range("A5").Value

With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Hope this is of some use

 

[landshark22]

It appears you're asking pretty much the same as in February and June of last year.
Here's what I would try based on the file you previously linked to.

Remove the formula from D10
Copy A5 and paste as value into D10

Put this sub in the sheet module

Private Sub Worksheet_Calculate()
    If Range("A5") <> Range("D10") Then
        Call ShiftDataLeft
    End If
End Sub

Put this sub into a standard code module

Sub ShiftDataLeft()
  
    Dim WS As Worksheet
    Dim rng As Range
    Dim dateRng As Range
    Dim dataRng As Range
    Dim firstCopyCol As Long
    Dim arr
  
Set WS = ThisWorkbook.Sheets("Troop to Task")
Set dateRng = WS.Range("D10:AX10")
Set dataRng = WS.Range("D11:AX79")

' find column of A5
For Each rng In dateRng
    If rng.Value = Range("A5").Value Then
        firstCopyCol = rng.Column
        Exit For
    End If
Next rng

' check date exists
If firstCopyCol = 0 Then
    MsgBox "Date not found"
    Exit Sub
End If

With Application
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

' shift data
With dataRng
    arr = .Offset(, firstCopyCol - 4).Resize(, 47 - firstCopyCol + 4).Value
    .ClearContents
    .Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End With

dateRng.Cells(1) = WS.Range("A5").Value

With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Hope this is of some use

 

[NoSparks]

Post #3 is nothing but a quote of post #2, I suspect and would hope that you intended to say something regarding this code working or not working for you.

 

[landshark22]

Post #3 is nothing but a quote of post #2, I suspect and would hope that you intended to say something regarding this code working or not working for you.

Whoops, yea, so I pasted a5 to d10, inputted the codes and all it did was delete d10 after the day expired

 

[NoSparks]

I guess either I wasn't specific enough with what to do or you didn't do what I thought I had indicated.
Here's a link to the file I used that has the code installed.
For testing purposes you can change the A5 date just by adding a day(s) to the A5 formula like this
=TODAY() + 1
or +2 for 2 days from now or +3 for 3 days from now so you can see what happens.