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]

You can try this.

Sub bolder()
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim k, lr As Long
        Dim wk1 As Worksheet, wk2 As Worksheet
        Dim v
        v = Array("Date", "ID", "Start")
        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
                    If dic.Exists(wk1.Range("A" & k).Value) = False Then
                        dic(wk1.Range("A" & k).Value) = k
                         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)
                         
                    Else
                        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)
                    End If
            Next k
        
        End With
        
        lc = wk2.Cells.Find("*", LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        
        With wk2
            .Range("A1").Resize(1, 3) = v
            Do
                .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "Shift"
                .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "Break"
                k = .Cells(1, Columns.Count).End(xlToLeft).Column
            Loop While k <= lc
        .Cells(1, .Cells.Find("*", LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column).EntireColumn.Delete
        End With
End Sub

 

[decent_boy]

Thank you so much for your support

 

[decent_boy]

Thank you so much for your support

Sorry, in mac system, this macro is giving me error 429 activex component cant create object

 

[shinigamilight]

It's not working cuz macs don't have dictionary and scripting runtime. You can try this one.

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
                             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 , this is perfect

 

[decent_boy]

Thank you so much , this is perfect

Here I want to let you now that col a. Isn't not a unique ID col but col b of date is a unique so I think that mycol is for col because I enter different dates

 

[decent_boy]

You can try this.

Sub bolder()
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim k, lr As Long
        Dim wk1 As Worksheet, wk2 As Worksheet
        Dim v
        v = Array("Date", "ID", "Start")
        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
                    If dic.Exists(wk1.Range("A" & k).Value) = False Then
                        dic(wk1.Range("A" & k).Value) = k
                         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)
                       
                    Else
                        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)
                    End If
            Next k
      
        End With
      
        lc = wk2.Cells.Find("*", LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
      
        With wk2
            .Range("A1").Resize(1, 3) = v
            Do
                .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "Shift"
                .Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1) = "Break"
                k = .Cells(1, Columns.Count).End(xlToLeft).Column
            Loop While k <= lc
        .Cells(1, .Cells.Find("*", LookIn:=xlFormulas, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column).EntireColumn.Delete
        End With
End Sub

66

 

[decent_boy]

HI
I am using code for mac (Dim MyCol As New Collection) which you provided and when I add further data of date 1/24/2023, this does not copy in result sheet and macro copy only 1/23/2023 data

Book1
	A	B	C	D	E
1	Employee ID	Date	Start	Duration	Break
2	DX1001	1/23/2023	9:38 AM	1:53
3	DX1001	1/23/2023	1:57 PM	0:39	2:25
4	DX1001	1/23/2023	2:46 PM	0:27	0:09
5	DX1007	1/23/2023	6:04 AM	0:47	0:00
6	DX1007	1/23/2023	6:58 AM	0:05	0:06
7	DX1007	1/23/2023	7:07 AM	0:46	0:03
8	DX1007	1/23/2023	7:59 AM	0:02	0:05
9	DX1007	1/23/2023	9:09 AM	0:07	1:07
10	DX1007	1/23/2023	9:22 AM	0:09	0:04
11	DX1007	1/23/2023	1:47 PM	0:43	4:15
12	DX1001	1/24/2023	9:38 AM	1:53
13	DX1001	1/24/2023	1:57 PM	0:39	2:25
14	DX1001	1/24/2023	2:46 PM	0:27	0:09
15	DX1007	1/24/2023	6:04 AM	0:47	0:00
16	DX1007	1/24/2023	6:58 AM	0:05	0:06
Data

Book1
	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 AM	1:53	2:25	0:39	0:09	0:27	0:00	0:00	0:00	0:00	0:00	0:00	0:00	0:00	0:00	0:00
3	1/23/2023	DX1007	6:04 AM	0:47	0:06	0:05	0:03	0:46	0:05	0:02	1:07	0:07	0:04	0:09	4:15	0:43	0:00	0:00
Result

 

[decent_boy]

Further result should be like this after running macro

Book1
	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 AM	1:53	2:25	0:39	0:09	0:27	0:00	0:00	0:00	0:00	0:00	0:00	0:00	0:00	0:00	0:00
3	1/23/2023	DX1007	6:04 AM	0:47	0:06	0:05	0:03	0:46	0:05	0:02	1:07	0:07	0:04	0:09	4:15	0:43	0:00	0:00
4	1/24/2023	DX1001	9:38 AM	1:53	2:25	0:39	0:09	0:27
5	1/24/2023	DX1007	6:04 AM	0:47	0:06	0:05
Result