Copy all Rows with specific Name to new Sheet Solved/Closed

Question

Dear Friend,

Am having a Excel Timesheet with following columns
SITE - EMP NAME - EMP ID - EMP JOB TITLE -	DATE	 - TIME IN	-TIME OUT -	TOTAL -	NORMAL -	OT -	REMARKS

Site name  date, time in, time out , total , OT and Remarks columns keeps changing 

Do entry of time sheet every day in this excel workbook for one complete month and once month is completed segregation is done based on name with filter and copy paste to new sheet for each person.

Now am looking for a method by which the segregation part can be automated.

Your help in this regard will be appreciated...Thanks

vcoolio · Answer

Hello Somanrajan,


If I have understood your post correctly then the following code may do the job for you:-


Sub TransferData()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim ar As Variant
        Dim i As Integer

ar = Sheet1.Range("B2", Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp))

Sheet1.Select
  For i = 1 To UBound(ar)
         Range("B1", Range("B" & Rows.Count).End(xlUp)).AutoFilter 1, ar(i, 1)
         Range("A2", Range("K" & Rows.Count).End(xlUp)(2)).Copy Sheets(ar(i, 1)).Range("A" & Rows.Count).End(xlUp)(2)
         Sheet1.Range("A2", Range("K" & Rows.Count).End(xlUp)(2)).Delete
         Sheets(ar(i, 1)).Columns.AutoFit
    Next i
[B1].AutoFilter
 
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data transfer completed!", vbExclamation, "Status"

End Sub

I've assumed that you have already created the individual sheets with the same headings.

The code does the filtering, copying and pasting that you now do manually.
It also clears Sheet1 (which I also assume is your Input sheet which you may have named differently) once the data is transferred to each individual sheet.

Following is the link to my test work book for you to peruse. Click on the button to see it work:-

https://www.dropbox.com/s/lzorqmpvvn1molo/Somanrajan%28Master%20sht%20to%20multi%20shts%29.xlsm?dl=0

I was wondering, as you are filtering by Employee Name (Column B), what if more than one employee has the same name? Perhaps it would be better to filter on the Employee ID.

I hope that this helps.

Cheerio,
vcoolio.

vcoolio · Answer

Hello Somanrajan,

Thanks for the link. It is clearer now what is happening.

Replace the above code with the following:-

Option Explicit

Sub TransferData()
Dim ar As Variant, i As Integer

ar = Array("2", "5", "6", "12", "13", "32", "34", "45", "56")
Application.ScreenUpdating = False

For i = 0 To UBound(ar, 1)
        With Sheet1
            .AutoFilterMode = False
                With Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, ar(i)
                    .Offset(1).EntireRow.Copy
                     Sheets(ar(i)).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
                     .Offset(1).EntireRow.Delete
                     Sheets(ar(i)).Columns.AutoFit
                     ActiveSheet.AutoFilterMode = False
                End With
        End With
    Next i
    
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "All done!", vbExclamation

End Sub


You can add to the array (line 6) should you wish to add more employees.

Following is the link to my updated test work book:-

https://www.dropbox.com/s/l3zmjry5wdcrwkb/Somanrajan%282%29.xlsm?dl=0

I have included a line of code (line 17) that will delete all data (except the headings) from the Input sheet once the data has been transferred to each individual sheet. If you do not want the data deleted, then just remove line 17 from the code.

I hope that this helps.

Cheerio,
vcoolio.

Somanrajan · Answer

Dear Friend,

Still this new code does not work ... when i try to run the code it just cuts and paste every thing in main sheet to the next sheet...

Wondering why?

vcoolio · Answer

Hello Somanrajan,

As you can see from the test work book at the link I provided above, the code works perfectly as it does in my personal file.

Is the file in the link that you supplied an actual replica of your work book?

Did you copy/paste the code correctly?

Did you alter the code at all?

Is there something else that we should know about your work book?

Cheerio,
vcoolio.

Somanrajan · Answer

Dear Friend,

I did changes in line 6 ar = Array("2", "5", "6", "12", "13", "32", "34", "45", "56")

I removed all the nos. , in actual sheet the numbers are different and have around 300 employee ids , but for testing i just entered  only two of them , and run the code , it only cut and pasted all the contents in main sheet to the next thats it in 511

changed line 6 ar = Array("511", "16")

pl. let me know what would have gone wrong

Thanks

vcoolio · Answer

Hello Somanrajan,

I have just tested with two IDs only as you have tried and it still works just fine.

I do not know what is going on with your actual work book.

Try the following loop type code instead:-

Sub TransferData2()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim i As Integer
        Dim lRow As Long
        Dim lCol As Long
        Dim MySheet As String
        
lRow = Range("C" & Rows.Count).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column

Sheet1.Select

For i = lRow To 2 Step -1
          MySheet = Cells(i, 3).Value
          Range(Cells(i, 1), Cells(i, lCol)).Copy Sheets(MySheet).Range("A" & Rows.Count).End(3)(2)
          'Range(Cells(i, 1), Cells(i, lCol)).Delete
          Sheets(MySheet).Columns.AutoFit
Next

Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
MsgBox "Data transfer completed!", vbExclamation, "STATUS"
Application.ScreenUpdating = True

End Sub

Let me know what happens next.

Cheerio,
vcoolio.

Somanrajan · Answer

Dear Friend,

The above code does nothing shows error


thanks

vcoolio · Answer

Hello Somanrajan,

Again, I have tested the last code above in the sample that you supplied and it also works perfectly.

So far, all the codes above work perfectly in the sample that you supplied.

I do not know what is going on with your work book. Is there something more that you should be telling us?

The error you see above means that the code cannot find the sheet(s) that it needs to transfer the data to. It is usually caused by people not spelling correctly such as spelling the criteria different to the sheet tab name. Even an incorrectly placed space will cause the error. Are your employee IDs in Column C different to the sheet tab name? Have you placed extra letters, spaces etc. in either?

For us to help you, you may have to upload your actual work book for us to test as we are not getting anywhere at the moment.

Cheerio,
vcoolio.

vcoolio · Answer

Hello again Somanrajan,

I've just been through the whole process again and I think that this time it should work. I've discovered the problem (I think!). It has been due to the fact that there is the complication that the list being created is based on employee numbers(totally numeric IDs).  This problem needs to be addressed as creating new sheets as numbers will not work without turning the numeric values to a text string (Excel can become a little temperamental at times!). To get around this the Cstr function will convert a number to text. Following is the updated code:-


Option Explicit

Sub CreateSheetsTransferData2()
        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row 'Trap the last row
Range("C1:C" & lr).AdvancedFilter 2, [P1], , 1 'Unique records only
ar = Range("P2", [P65536].End(xlUp)) 'Assign to array
Set sh = Sheet1 'Change to suit

For i = LBound(ar) To UBound(ar) 'Start the loop
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then 'Check sheet exists
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1) 'Add sheet if False
        End If
        Set ws = Worksheets(CStr(ar(i, 1))) 'Assign ws variable to sheet.
        sh.Range("C1:C" & lr).AutoFilter 1, ar(i, 1) 'Filter
        sh.[C1].CurrentRegion.Copy ws.[a1] 'Transfer the data
        ws.Columns.AutoFit
  Next i
    
sh.[B1].AutoFilter ' Clean up after this point
Application.ScreenUpdating = True
sh.Select 
sh.[P1:P100].Clear
MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS"

End Sub

Column P is being used as a "helper" column to hold the list of IDs. This will expand as you add more IDs.

Following is the link to the updated file:-

https://www.dropbox.com/s/xdy5bf0nxtbk80r/Somanrajan%284%29.xlsm?dl=0

In the code above, there are notes (in green font) that help to explain what is happening within the code.

It should all be OK now.

Cheerio,
vcoolio.

Somanrajan · Answer

Dear Friend,

Still not working...original file link below

https://www.dropbox.com/s/jx40tmtfh3z96fx/orginal%20view.xlsx?dl=0

Pl. check and see whats going wrong

Thanks

vcoolio · Answer

Hello Somanrajan,

Now that I have seen your actual work book, the code in my post#10 above will work with slight modification as you have many blanks in Column C.

Option Explicit

Sub CreateSheetsTransferData2()
        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False

lr = Range("A" & Rows.Count).End(xlUp).Row 'Trap the last row
Range("C1:C" & lr).AdvancedFilter 2, [P1], , 1 'Unique records only
Range("P2", [P65536].End(xlUp)).Sort [P2], 1  ' Takes care of blank cells from Column C

ar = Range("P2", [P65536].End(xlUp)) 'Assign to array
Set sh = Sheet1 'Change to suit

For i = LBound(ar) To UBound(ar) 'Start the loop
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then 'Check sheet exists
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1) 'Add sheet if False
        End If
        Set ws = Worksheets(CStr(ar(i, 1))) 'Assign ws variable to sheet.
        sh.Range("C1:C" & lr).AutoFilter 1, ar(i, 1) 'Filter
        sh.[C1].CurrentRegion.Copy
        ws.[a1].PasteSpecial xlPasteValues 'Transfer the data
        ws.Columns.AutoFit
  Next i
    
sh.[B1].AutoFilter ' Clean up after this point
Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
sh.[P:P].Clear
MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS"

End Sub

You'll see that line 14 is the additional line of code which will compensate for the blank cells in Column C.

Following is the link to the updated file (using your actual work booK);-

https://www.dropbox.com/s/e0gcap7yilhnofx/Somanrajan%285%29.xlsm?dl=0

The code will create sheets and transfer data to each individual sheet.
Click on the "RUN" button to see it work.

You'll need to define a named range in your work book (Column P in this case) as you'll see in the link above.

Cheerio,
vcoolio.

Somanrajan · Answer

Dear Friend,

Its perfect..Thanks and really appreciate your patience and will to solve the problem.

Thank you again sir.

vcoolio · Answer

Hello Somanrajan,

You're welcome. I'm glad that we were able to solve it for you.

Good luck!

Cheerio,
vcoolio.

Copy all Rows with specific Name to new Sheet

13 responses

Similar discussions

Subscribe To Our Newsletter!