How to Separate the worksheet based on data
Closed
hariharanp
vcoolio
- Posts
- 1
- Registration date
- Friday December 11, 2015
- Status
- Member
- Last seen
- December 11, 2015
vcoolio
- Posts
- 1345
- Registration date
- Thursday July 24, 2014
- Status
- Moderator
- Last seen
- May 20, 2022
Related:
- How to Separate the worksheet based on data
- Populate separate worksheets with data from main worksheet based on criteria met ✓ - Forum - Excel
- Macro to pull data from another worksheet based on criteria ✓ - Forum - Excel
- Create worksheet based on lists & populate data from another... ✓ - Forum - Excel
- Vba split data into multiple worksheets based on column ✓ - Forum - Excel
- How to copy an entire row to another worksheet based on cell value in excel ✓ - Forum - Excel
1 reply
vcoolio
Dec 12, 2015 at 04:18 AM
- Posts
- 1345
- Registration date
- Thursday July 24, 2014
- Status
- Moderator
- Last seen
- May 20, 2022
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:-
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.
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.