Macro Transport Data

[decent_boy]

I have data sheet and there are columns of Employee ID, Date, Start, Duration, & Break I want a macro to copy data sheet data and transpose it in result sheet, same as result sheet example I am showing below.

Shift is in col D in data sheet
Break is in col E in data sheet

Book2
	A	B	C	D	E
1	Employee ID	Date	Start	Duration	Break
2	DX1001	1/23/2023	9:38 AM	1:53:17
3	DX1001	1/23/2023	1:57 PM	0:39:39	2:25:25
4	DX1001	1/23/2023	2:46 PM	0:27:10	0:09:55
5	DX1007	1/23/2023	6:04 AM	0:47:32	0:00:00
6	DX1007	1/23/2023	6:58 AM	0:05:44	0:06:44
7	DX1007	1/23/2023	7:07 AM	0:46:50	0:03:18
8	DX1007	1/23/2023	7:59 AM	0:02:49	0:05:03
9	DX1007	1/23/2023	9:09 AM	0:07:39	1:07:50
10	DX1007	1/23/2023	9:22 AM	0:09:22	0:04:57
11	DX1007	1/23/2023	1:47 PM	0:43:21	4:15:13
Data

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	DATE	ID	Start	Shift	Break	Shift	Break	Shift	Break	Shift	Break	Shift	Break	Shift	Break	Shift	Break	Shift
2	1/23/2023	DX1001	9:38:18 AM	1:53:17	2:25:25	0:39:39	0:09:55	0:27:10	0:00:00	0:00:00	0:00:00	0:00:00	0:00:00	0:00:00	0:00:00	0:00:00	0:00:00	0:00:00
3	1/23/2023	DX1007	6:04:08 AM	0:47:32	0:06:44	0:05:44	0:03:18	0:46:50	0:05:03	0:02:49	1:07:50	0:07:39	0:04:57	0:09:22	4:15:13	0:43:21	0:00:00	0:00:00
Result

 

[shinigamilight]

Sub Transpose_ColRows()
        Dim MyCol As New Collection
        Dim k, lr As Long
        Dim wk1 As Worksheet, wk2 As Worksheet
        Dim v
        Dim Temp
        v = Array("Date", "ID", "Start", "Shift", "Break")
        Set wk1 = Sheets("Data")                                      'change your sheet
        Set wk2 = Sheets.Add
        
        lr = wk1.Range("A" & Rows.Count).End(xlUp).Row

        With wk2
            For k = 2 To lr
                             On Error GoTo ErrorGoNext
                             MyCol.Add 1, wk1.Range("A" & k).Value & wk1.Range("B" & k).Value
                             On Error GoTo 0
                             wk1.Range("B" & k).Copy .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                             wk1.Range("A" & k).Copy .Cells(.Range("A" & Rows.Count).End(xlUp).Row, Columns.Count).End(xlToLeft).Offset(0, 1)
                             wk1.Range("C" & k).Resize(1, 2).Copy .Cells(.Range("A" & Rows.Count).End(xlUp).Row, Columns.Count).End(xlToLeft).Offset(0, 1)
                                GoTo EarlyExit
ErrorGoNext:
                            wk1.Range("E" & k).Copy .Cells(.Range("A" & Rows.Count).End(xlUp).Row, Columns.Count).End(xlToLeft).Offset(0, 1)
                            wk1.Range("D" & k).Copy .Cells(.Range("A" & Rows.Count).End(xlUp).Row, Columns.Count).End(xlToLeft).Offset(0, 1)
                            Resume EarlyExit
EarlyExit:
            Next k
        End With
        
        lc = wk2.Cells.Find("*", LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        
            With wk2
                .Range("A1").Resize(1, 5) = v
                .Range("D1:E1").AutoFill .Range("D1", .Cells(1, lc))
            End With
End Sub

 

[decent_boy]

Thank you so much it works perfect