Previous Topic Next Topic

How to Separate the worksheet based on data

Closed
hariharanp
Posts
1
Registration date
Friday December 11, 2015
Status
Member
Last seen
December 11, 2015
 - Dec 11, 2015 at 09:05 PM
vcoolio
Posts
1345
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
May 20, 2022
 - Dec 12, 2015 at 04:18 AM
Dear Sir.

I had the data as mentioned below for your reference

CODE EMPNAME EB HRA GROSS
175702 MAURICE J P 10,140 6,760 16,900
175702 MAURICE J P 10,010 6,890 16,900
175702 MAURICE J P 10,010 6,890 16,900
175702 MAURICE J P 10,010 6,890 16,900
175702 MAURICE J P 10,010 6,890 16,900
175702 MAURICE J P 10,010 6,890 16,900
175702 MAURICE J P 10,010 6,890 16,900
175479 KRANTHI KUMAR D 10,140 5,360 15,500
175479 KRANTHI KUMAR D 10,010 2,990 13,000
175479 KRANTHI KUMAR D 10,010 2,990 13,000
175479 KRANTHI KUMAR D 9,687 2,894 12,581
175479 KRANTHI KUMAR D 10,010 2,990 13,000
175479 KRANTHI KUMAR D 0 2,489 2,489
175479 KRANTHI KUMAR D 10,010 2,990 13,000
175479 KRANTHI KUMAR D 10,010 501 10,511
175483 ANBUKANNAN K A 11,024 6,991 18,015
175483 ANBUKANNAN K A 11,024 6,991 18,015
175483 ANBUKANNAN K A 11,024 6,991 18,015

In excel based on employee code the sheet should get separate, It related to tax working please guide me.

1 reply

Answer 1 / 1
vcoolio
Posts
1345
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
May 20, 2022
 249
Dec 12, 2015 at 04:18 AM
Hello Hari,

From what I interpret from your post, you would like individual sheets created for each employee based on their ID with all their relevant data transferred to their individual sheet. If this is so, then the following code should do the task for you:- 


Sub CreateSheetsCopyData()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

        Dim ar As Variant
        Dim i As Integer
        Dim LR As Long
        Dim c As Range
        Dim ws As Worksheet
        
ar = Array("175702", "175479", "175483")
LR = Range("A" & Rows.Count).End(xlUp).Row

For Each c In Range("A2:A" & LR)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Worksheets(c.Value)
        If ws Is Nothing Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value
        End If
  Next c
      
Sheet1.Select
    For i = 0 To UBound(ar)
         Range("A1", Range("A" & Rows.Count).End(xlUp)).AutoFilter 1, ar(i)
         Range("B1", Range("E" & Rows.Count).End(xlUp)).Copy Sheets(ar(i)).Range("A" & Rows.Count).End(xlUp)
         Sheets(ar(i)).Columns.AutoFit
    Next i
   [A1].AutoFilter
   
For Each ws In ActiveWorkbook.Sheets
    If ws.Range("A1") = "" Then ws.Delete
Next ws
   
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transfer completed!", vbExclamation, "Status"

End Sub


I have assumed that the data starts in Row 2 with headings in Row 1. I have attached my test work book for you to peruse at the following link:-

https://www.dropbox.com/s/4hecoa7yc632eu1/Hariharanp.xlsm?dl=0

I hope that this helps,

Cheerio,
vcoolio.
0