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 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 - Dec 12, 2015 at 04:18 AM
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 - Dec 12, 2015 at 04:18 AM
Related:
- How to Separate the worksheet based on data
- Transfer data from one excel worksheet to another automatically - Guide
- Tmobile data check - Guide
- Gta 5 data download for pc - Download - Action and adventure
- Data transmission cable - Guide
- Based on the values in cells b77 b88 ✓ - Excel Forum
1 response
vcoolio
Posts
1411
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
September 6, 2024
262
Dec 12, 2015 at 04:18 AM
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.