Automating Shift work Schedule Update

[rcocrane99]

So every day my work makes a sheet were we detail specific categories of tasks and what happened during that day. The night shift comes in and creates a new sheet then, transfers all of the information to the cell below and then rinse and repeat. Is there any way to automate this process to reduce the amount of copy and pasting we do?
End of Day Shift example:

Start of Night Shift Example:

 

[MikeVol]

Hello @rcocrane99. Maybe I misunderstood you. Insert this code into the standard module.

Option Explicit

Sub CopyAndClearData()
    Dim ws1         As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")

    Dim ws2         As Worksheet
    Set ws2 = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets("Sheet1"))

    Dim currentTime As Date
    Dim suffix      As String
    currentTime = Time

    If Hour(currentTime) >= 6 And Hour(currentTime) < 18 Then
        suffix = "D"    ' Daytime
    Else
        suffix = "A"    ' Night time
    End If

    Dim newName     As String
    newName = Format(Now, "d MMM") & " " & suffix

    On Error Resume Next
    ws2.Name = newName
    If Err.Number <> 0 Then
        MsgBox "Failed to set sheet name: " & newName, vbExclamation
        Err.Clear
    End If
    On Error GoTo 0

    ws1.Cells.Copy
    ws2.Cells.PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

    ws1.Range("B12").Value = ws1.Range("B11").Value
    ws1.Range("B11").ClearContents

    ws1.Range("C12").Value = ws1.Range("C11").Value
    ws1.Range("C11").ClearContents

    ws1.Range("B15").Value = ws1.Range("B14").Value
    ws1.Range("B14").ClearContents

    ws1.Range("C15").Value = ws1.Range("C14").Value
    ws1.Range("C14").ClearContents

    MsgBox "Done, completed!", vbInformation
End Sub

Run it on each new shift. Please check if this is the result you wanted. Good luck.

 

[rcocrane99]

So I've been advised to work with Chat GPT with something like this as it makes explaining your needs a little easier, I' very new to VBA so this probably would of taken a while to complete but here is what it ended up with. As it was able to produce the code and it worked well i added more and more features.

Sub ShiftUpdate()
' Declare variables for source and target ranges
Dim sourceRange As Range
Dim targetRange As Range
Dim shape As shape
Dim newSheet As Worksheet
Dim currentSheet As Worksheet
Dim newSheetName As String
Dim currentHour As Integer
Dim currentDate As Date
Dim i As Integer

' Set the shape variable to the shape that runs the macro (replace "ShapeName" with the actual name of the shape)
Set shape = ActiveSheet.Shapes(Application.Caller)

' Save the current active sheet to a variable
Set currentSheet = ActiveSheet

' Duplicate the current sheet
currentSheet.Copy After:=Sheets(Sheets.Count)

' Set the new sheet to be the last sheet (the duplicated one)
Set newSheet = ActiveSheet

' Activate the new sheet
newSheet.Activate

' Get the current hour
currentHour = Hour(Now)

' Determine the date for sheet renaming
If currentHour >= 0 And currentHour < 1 Then
' If between 12 AM and 1 AM, set the date to the previous day
currentDate = Date - 1
Else
' Otherwise, use the current date
currentDate = Date
End If

' Generate the new sheet name in "mmm d" format
newSheetName = Format(currentDate, "mmm dd")

' Append " D" or " A" based on the time
If currentHour >= 4 And currentHour < 12 Then
newSheetName = newSheetName & "D" ' From 4 AM to 1:30 PM
Else
newSheetName = newSheetName & "A" ' From 2:30 PM to 1 AM
End If

' Rename the new sheet
On Error Resume Next ' In case a sheet with the same name already exists
newSheet.Name = newSheetName
On Error GoTo 0 ' Reset error handling

' Process the B:G ranges from rows 3 to 7 (e.g. B3:G3 to H3:M3, B4:G4 to H4:M4, etc.)
For i = 3 To 7
CopyAndClear newSheet, "B" & i & ":G" & i, "H" & i & ":M" & i
Next i

' Process the B:G ranges (B11:G11 to B12:G12, etc.)
CopyAndClear newSheet, "B11:G11", "B12:G12"
CopyAndClear newSheet, "B14:G14", "B15:G15"
CopyAndClear newSheet, "B17:G17", "B18:G18"
CopyAndClear newSheet, "B20:G20", "B21:G21"
CopyAndClear newSheet, "B23:G23", "B24:G24"
CopyAndClear newSheet, "B26:G26", "B27:G27"
CopyAndClear newSheet, "B30:G30", "B31:G31"
CopyAndClear newSheet, "B33:G33", "B34:G34"
CopyAndClear newSheet, "B36:G36", "B37:G37"
CopyAndClear newSheet, "B40:G40", "B41:G41"
CopyAndClear newSheet, "B44:G44", "B45:G45"
CopyAndClear newSheet, "B47:G47", "B48:G48"

' Process the H:M ranges (H11:M11 to H12:M12, etc.)
CopyAndClear newSheet, "H11:M11", "H12:M12"
CopyAndClear newSheet, "H14:M14", "H15:M15"
CopyAndClear newSheet, "H17:M17", "H18:M18"
CopyAndClear newSheet, "H20:M20", "H21:M21"
CopyAndClear newSheet, "H23:M23", "H24:M24"
CopyAndClear newSheet, "H26:M26", "H27:M27"
CopyAndClear newSheet, "H30:M30", "H31:M31"
CopyAndClear newSheet, "H33:M33", "H34:M34"
CopyAndClear newSheet, "H36:M36", "H37:M37"
CopyAndClear newSheet, "H40:M40", "H41:M41"
CopyAndClear newSheet, "H44:M44", "H45:M45"
CopyAndClear newSheet, "H47:M47", "H48:M48"

' Update cells I1:M1 with the current date in dd mmm yy format
newSheet.Range("I1:M1").Value = Format(currentDate, "dd mmm yy")

End Sub

' Function to copy a range and clear its contents
Sub CopyAndClear(ByVal sheet As Worksheet, ByVal sourceRangeAddress As String, ByVal targetRangeAddress As String)
Dim sourceRange As Range
Dim targetRange As Range

' Set the source and target ranges
Set sourceRange = sheet.Range(sourceRangeAddress)
Set targetRange = sheet.Range(targetRangeAddress)

' Check if the source range is not blank
If Application.WorksheetFunction.CountA(sourceRange) > 0 Then
' Copy the data if the source range has data
sourceRange.Copy Destination:=targetRange
' Clear the source range after copying
sourceRange.ClearContents
End If
End Sub