Selected Answer
Saxon
In the attached file, I've added a macro to "summarise" each block of machine data provided:
- The first block starts after row 2
- There's a gap between blocks (e.g. your rows 16 and 32)
- The last record per machine has a Time in column E at least (note that I formatted columns E and F as Time and corrected values- this is needed later, when the record date is added on summarsing).
The new sheet "Copied sheet" is just for test purposes (copying data back to sheet 1) and should be deleted once you've tested.
There's a green button at the top of Sheet1 (near the top of columns J:L) called "Create new summary file" which is assigned to the sheet macro below - press that and you may be asked to save the file (if there have been changes) and will be asked to provide two dates. The code below is commented so you can (hopefully) follow the logic:
Public Sub CollectLastActivity()
Dim n As Long, LstArray As Variant, fName As String
Dim NwDate As Date, RecDate As Date, r As VbMsgBoxResult
' disable save alerts
Application.DisplayAlerts = False
'check this file has been saved
If ThisWorkbook.Saved = False Then
r = MsgBox("You must save this file before summarising, okay?", vbYesNo, "File changed since last save...")
If r = vbNo Then Exit Sub
ThisWorkbook.Save
End If
' see how save date compares to today
NwDate = InputBox("What date is the NEW summary file needed for? (E.g. tomorrow- please correct)" & vbCr & "(Today is " & Date & ")", "Creating new file...", Date)
If IsDate(NwDate) = False Then Exit Sub
' see when records were from (and check they're not after new date?!
RecDate = InputBox("What date are these records from? (Please correct)", "Creating new file", Date - 1)
If IsDate(RecDate) = False Or RecDate > NwDate Then Exit Sub
Fnd = 0
' find last row per section (based on Start time)
' loop backwards from end of used range
For n = Range("A1").SpecialCells(xlCellTypeLastCell).Row To 2 Step -1
' compare the array values, if it exists
If Not IsEmpty(LstArray) Then
'compare array values
For m = 1 To UBound(LstArray, 2)
' if a cell is empty, overwrite it
If Trim(LstArray(1, m)) = "" Then LstArray(1, m) = Cells(n, m + 1).Value
Next m
End If
' if no array, check if end of data block
If Cells(n, 5) <> "" And Fnd = 0 Then
'collect last line of data block
LstArray = Range(Cells(n, 2), Cells(n, 9)).Value
Fnd = n
Else
If n = 2 Or (Cells(n, 5) = "" And Fnd > 0) Then
' adjust so code below works
If n = 2 Then n = 1
' gap in data so clear data from collected range
Range(Cells(n + 1, 2), Cells(Fnd, 9)).ClearContents
' add user provided record date to last Start and Stop fields
LstArray(1, 4) = RecDate & " " & CDate(LstArray(1, 4))
LstArray(1, 5) = RecDate & " " & CDate(LstArray(1, 5))
' copy array to row below
Range(Cells(n + 1, 2), Cells(n + 1, 9)).Value = LstArray
' empty the array
ReDim LstArrray(UBound(LstArray, 1), UBound(LstArray, 2))
' reset the found variable
Fnd = 0
End If
End If
Next n
' adjust columns
Columns("A:I").AutoFit
'Define new file name with path
fName = ThisWorkbook.Path & "\" & Format(NwDate, "yyyy_mmm_dd") & ".xlsm"
' save file with new date from user, using 52 (for PC) for macro enabled workboo
ThisWorkbook.SaveAs fName, 52
Application.DisplayAlerts = True
' tell user what happened
MsgBox "Saved! This new file is at " & fName
End Sub
It will "flatten" the data per machine (it should cope with more that 3 machines per file) and save the summary in a new named file (e.g. 2023_Jan_08.xlsm) in the same folder as where the original file is stored.That file can be opened on that date and populated with events. It will have the same button/ code and can be used to create the next day's file etc..
Note that I didn't add a new date column (as I'd suggested) but made the summary Start and Stop entries include the date of the record e.g. 01/06/2023 10:00
I notice that your conditional formnatting rules probably need some rationlisation but I don't have time to do that!
Hope this works well for you.