Move rows to new tabs grouping multiple rows with same column values

[johnasmith13]

I would like to have a macro that would move each lines of each employee to a separate tab that is the employee's name and leave the weekly summary tab as is.
The attached screen clip further explains!

Thank you so much!!

Rows to New Tabs by Employee Each 4-2-2021.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L
1	ID #	Employee Code:#:	Employee Name:	Date	IN	OUT	IN	OUT	Daily Clock Hours	Eligible?	Worked AM - PM	Daily Hours w/ Guarantee
2	2130	J63864	Employee1	Tue 03/16/2021	6:51AM	8:29AM	10:09AM	12:17PM
3	2130	J63864	Employee1	Tue 03/16/2021	1:22PM	3:16PM			5.67	7	Yes	7
4	2130	J63864	Employee1	Wed 03/17/2021	6:51AM	8:28AM	10:10AM	11:53AM
5	2130	J63864	Employee1	Wed 03/17/2021	1:22PM	3:25PM			5.38	7	Yes	7
6	2573	I72647	Employee2	Tue 03/16/2021	6:50AM	10:09AM	1:28PM	4:40PM	6.52	7	Yes	7
7	2573	I72647	Employee2	Wed 03/17/2021	6:45AM	10:08AM	1:22PM	4:30PM	6.52	7	Yes	7
8	2573	I72647	Employee2	Thu 03/18/2021	6:50AM	10:34AM	1:25PM	4:47PM	7.1	7	Yes	7.1
9	2573	I72647	Employee2	Fri 03/19/2021	6:49AM	10:29AM			3.67	7	No	3.67
10	2366	G74253	Employee3	Tue 03/16/2021	5:40AM	10:04AM	10:12AM	5:02PM	11.23	7	Yes	11.23
11	2366	G74253	Employee3	Wed 03/17/2021	5:34AM	10:08AM	10:31AM	4:31PM	10.57	7	Yes	10.57
12	2366	G74253	Employee3	Fri 03/19/2021	5:47AM	10:00AM	11:41AM	4:42PM	9.23	7	Yes	9.23
13	2538	L72170	Employee4	Tue 03/16/2021	5:49AM	9:41AM	9:50AM	12:04PM
14	2538	L72170	Employee4	Tue 03/16/2021	12:53PM	4:44PM			9.95	7	Yes	9.95
15	2538	L72170	Employee4	Wed 03/17/2021	5:50AM	12:19PM	12:50PM	4:56PM	10.58	7	Yes	10.58
16	2538	L72170	Employee4	Thu 03/18/2021	5:49AM	12:10PM	12:53PM	4:47PM	10.25	7	Yes	10.25
17	2538	L72170	Employee4	Fri 03/19/2021	5:50AM	12:03PM	12:56PM	4:47PM	10.07	7	Yes	10.07
18	2131	C63833	Employee5	Tue 03/16/2021	6:18AM	9:31AM	10:23AM	11:51AM
19	2131	C63833	Employee5	Tue 03/16/2021	1:19PM	4:44PM			8.1	7	Yes	8.1
20	2131	C63833	Employee5	Wed 03/17/2021	6:37AM	9:31AM	10:28AM	11:50AM
21	2131	C63833	Employee5	Wed 03/17/2021	1:21PM	4:49PM			7.73	7	Yes	7.73
22	2131	C63833	Employee5	Thu 03/18/2021	6:26AM	9:30AM	10:23AM	11:50AM
23	2131	C63833	Employee5	Thu 03/18/2021	1:22PM	4:41PM			7.83	7	Yes	7.83
24	2131	C63833	Employee5	Fri 03/19/2021	6:32AM	9:35AM	10:29AM	11:59AM
25	2131	C63833	Employee5	Fri 03/19/2021	1:22PM	5:00PM			8.18	7	No	8.18
3-15 to 3-21-21 (Week)

 

[igold]

Hi johnasmith13, welcome to the MrExcel forum.

Does this do what you are looking for...

Sub MoveRows()
    
    Dim arr
    Dim ws As Worksheet, wsMain As Worksheet
    Dim x As Long, i As Long
    Dim rng As Range, rng2 As Range
    
    Application.ScreenUpdating = False
    Set wsMain = ActiveSheet
    Set rng2 = ActiveSheet.UsedRange.Offset(1, 0)
    arr = rng2
    With CreateObject("Scripting.Dictionary")
    For x = LBound(arr) To UBound(arr) - 1
        If Not IsMissing(arr(x, 3)) Then .Item(arr(x, 3)) = 1
    Next
    arr = .Keys
    End With
    For i = LBound(arr) To UBound(arr)
        rng2.AutoFilter
        wsMain.Range("C1").AutoFilter
        wsMain.UsedRange.AutoFilter Field:=3, Criteria1:=arr(i), Operator:=xlFilterValues
        Set rng = ActiveSheet.AutoFilter.Range
        Set ws = Worksheets.Add
        rng.Copy Range("A1")
        ActiveSheet.Name = arr(i)
        wsMain.Activate
    Next
    ActiveSheet.AutoFilter.ShowAllData
    Application.ScreenUpdating = True
    
End Sub

 

[johnasmith13]

Hi johnasmith13, welcome to the MrExcel forum.

Does this do what you are looking for...

Sub MoveRows()
   
    Dim arr
    Dim ws As Worksheet, wsMain As Worksheet
    Dim x As Long, i As Long
    Dim rng As Range, rng2 As Range
   
    Application.ScreenUpdating = False
    Set wsMain = ActiveSheet
    Set rng2 = ActiveSheet.UsedRange.Offset(1, 0)
    arr = rng2
    With CreateObject("Scripting.Dictionary")
    For x = LBound(arr) To UBound(arr) - 1
        If Not IsMissing(arr(x, 3)) Then .Item(arr(x, 3)) = 1
    Next
    arr = .Keys
    End With
    For i = LBound(arr) To UBound(arr)
        rng2.AutoFilter
        wsMain.Range("C1").AutoFilter
        wsMain.UsedRange.AutoFilter Field:=3, Criteria1:=arr(i), Operator:=xlFilterValues
        Set rng = ActiveSheet.AutoFilter.Range
        Set ws = Worksheets.Add
        rng.Copy Range("A1")
        ActiveSheet.Name = arr(i)
        wsMain.Activate
    Next
    ActiveSheet.AutoFilter.ShowAllData
    Application.ScreenUpdating = True
   
End Sub

Thank you for your reply! I got a 400 Error (see screen clip)...... Any suggestions?

John

 

[johnasmith13]

Thank you for your reply! I got a 400 Error (see screen clip)...... Any suggestions?

John

I pasted it into the Module and it worked like a charm!!! Oh thank you so very much!!!!

 

[igold]

Great, I am glad you got it working, I was happy to help. Thanks for the feedback!