Grab only necessary data make new sheet

I have attached an example of what i am trying to accomplish. I have data that i have used formulas to grab. But it is all over the place and some are not even in the right columns etc. Sheet 1 describes how my formulas position the data i get. Sheet 4 is how i want it to look. So i am not sure if i can get a macro that puts all the data on another sheet or what? Any ideas would be great. Also i want it to add some information (see column g on sheet 4)

Oh and only the highlighted data is what i need, i do not need the other stuff. Basically just time periods that have a start date and time and end time.

Thank you in advance.

Try this

Option Explicit

Sub TidySheet()
    Dim n As Integer
    Dim RowNo As Long, LastRow As Long
    Dim ColNo As Long, LastCol As Long
    Dim rng As Range
    Dim arrData() As Variant
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    On Error GoTo ResetApplication
    
    Set rng = ActiveSheet.UsedRange
    LastRow = rng.Rows.Count
    LastCol = rng.Columns.Count
    
    Range("A:A").Clear
    Range("A1") = "Employee ID"
    Range("B1") = "Name of Employee"
    
    For RowNo = LastRow To 3 Step -1
        ReDim arrData(0)
        n = 0
        For ColNo = 1 To LastCol
            If Cells(RowNo, ColNo) <> "" Then
                arrData(n) = Cells(RowNo, ColNo)
                n = n + 1
                ReDim Preserve arrData(n)
            End If
        Next
        Select Case UBound(arrData)
            Case 0
                Rows(RowNo).Delete
            Case 3
                If Not IsNumeric(arrData(1)) Then
                    Rows(RowNo).Delete
                Else
                    Rows(RowNo).Clear
                    Cells(RowNo, "C") = arrData(0)
                    Cells(RowNo, "D") = arrData(1)
                    Cells(RowNo, "F") = arrData(2)
                    
                    If Cells(RowNo, "F") < 0.5 Then
                        Cells(RowNo, "E") = arrData(0) + 1
                    Else
                        Cells(RowNo, "E") = arrData(0)
                    End If
                End If
            Case 2
                If Not IsNumeric(arrData(1)) Then
                    Range("A2") = arrData(0)
                    Range("B2") = arrData(1)
                End If
                Rows(RowNo).Delete
            Case Else
                Rows(RowNo).Delete
        End Select
    Next
    Range("D:D,F:F").NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Columns.AutoFit
    Rows.AutoFit

ResetApplication:
    Err.Clear
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

It's a bit of a guess, but the best I can do with the sample.
N.B. it adds a day to the date where required

Hope this helps

[EDIT]

Just noticed I had overwritten the BU sheet in the sample sheet.

cant see anything in terms of functions on sheet1! what did you use?

Try this

Option Explicit

Sub TidySheet()
    Dim n As Integer
    Dim RowNo As Long, LastRow As Long
    Dim ColNo As Long, LastCol As Long
    Dim rng As Range
    Dim arrData() As Variant
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    On Error GoTo ResetApplication
    
    Set rng = ActiveSheet.UsedRange
    LastRow = rng.Rows.Count
    LastCol = rng.Columns.Count
    
    Range("A:A").Clear
    Range("A1") = "Employee ID"
    Range("B1") = "Name of Employee"
    
    For RowNo = LastRow To 3 Step -1
        ReDim arrData(0)
        n = 0
        For ColNo = 1 To LastCol
            If Cells(RowNo, ColNo) <> "" Then
                arrData(n) = Cells(RowNo, ColNo)
                n = n + 1
                ReDim Preserve arrData(n)
            End If
        Next
        Select Case UBound(arrData)
            Case 0
                Rows(RowNo).Delete
            Case 3
                If Not IsNumeric(arrData(1)) Then
                    Rows(RowNo).Clear
                    Cells(RowNo, "A") = arrData(0)
                    Cells(RowNo, "B") = arrData(1)
                Else: IsNumeric (arrData(1))
                    Rows(RowNo).Clear
                    Cells(RowNo, "C") = arrData(0)
                    Cells(RowNo, "D") = arrData(1)
                    Cells(RowNo, "F") = arrData(2)
                    
                    If Cells(RowNo, "F") < 0.5 Then
                        Cells(RowNo, "E") = arrData(0) + 1
                    Else
                        Cells(RowNo, "E") = arrData(0)
                    End If
                End If
            Case 2
                If IsNumeric(arrData(1)) Then
                    Rows(RowNo).Delete
                Else
                    Rows(RowNo).Clear
                    Cells(RowNo, "A") = arrData(0)
                    Cells(RowNo, "B") = arrData(1)
                End If
            Case Else
                Rows(RowNo).Delete
        End Select
    Next
    Range("D:D,F:F").NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Columns.AutoFit
    Rows.AutoFit

ResetApplication:
    Err.Clear
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Is that any better?

I tried your workbook but it still only has one person in there.

As does your posted workbook ..

You apparently have two in number employees.
One called "Position", the other "Cashier N-4", both have the same ID "40002", or am I wrong?

The first solution offered matched your requested table on Sheet "Sheet4" as far as was possible, note that there was no "split" in this requested table.

The second used the only option that was left "split" on the aforesaid "Position", and "Cashier N-4"

There are many clever people answering obsure questions on this forum, but as far as I am aware none of them have crystal balls.

In the upper regions of my failing frame, I have two standard Mk1 eyeballs, they are, I regret to inform you, unable to glean any more from your brief.
Perhaps the others I possess would do better if they were younger and fitter.

Fix your problem at source!

if you could just give original and desired results . then maybe functions can do it. vba certainly will given the correct info but no one knows exactly what you want( my crystal ball is at the opticians being re-ground as vari-focal )

Okay here's another attempt.

Option Explicit

Sub TidySheet()
    Dim n As Integer
    Dim RowNo As Long, LastRow As Long
    Dim ColNo As Long, LastCol As Long
    Dim rng As Range
    Dim arrData() As Variant
    Dim strName As String
    Dim NameID As String
                    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    On Error GoTo ResetApplication
    
    Range("K:K").Clear
    
    Set rng = ActiveSheet.UsedRange
    LastRow = rng.Rows.Count
    LastCol = rng.Columns.Count
    
    For RowNo = LastRow To 2 Step -1
        ReDim arrData(0)
        n = 0
        For ColNo = 1 To LastCol
            If Cells(RowNo, ColNo) <> "" Then
                arrData(n) = Cells(RowNo, ColNo)
                n = n + 1
                ReDim Preserve arrData(n)
            End If
        Next
        Select Case UBound(arrData)
            Case 0
                Rows(RowNo).Delete
            Case 3
                If Not IsNumeric(arrData(1)) Then
                    Rows(RowNo).Clear
                    Cells(RowNo, "A") = arrData(0)
                    Cells(RowNo, "B") = arrData(1)
                Else
                    Rows(RowNo).Clear
                    Cells(RowNo, "C") = arrData(0)
                    Cells(RowNo, "D") = arrData(1)
                    Cells(RowNo, "F") = arrData(2)
                    
                    If Cells(RowNo, "F") < 0.5 Then
                        Cells(RowNo, "E") = arrData(0) + 1
                    Else
                        Cells(RowNo, "E") = arrData(0)
                    End If
                End If
            Case 2
                If IsNumeric(arrData(1)) Then
                    Rows(RowNo).Delete
                Else
                    If Cells(RowNo, "C") <> "" Then
                        NameID = arrData(0)
                        strName = arrData(1)
                        Rows(RowNo).Delete
                    Else
                        Rows(RowNo).Delete
                    End If
                End If
            Case 1
                If Cells(RowNo, "A") = "" Then
                    Rows(RowNo).Delete
                End If
            Case Else
                Rows(RowNo).Delete
        End Select
    Next
    Range("D:D,F:F").NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Columns.AutoFit
    Rows.AutoFit

ResetApplication:
    Err.Clear
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Let me know how this one goes.