Hi,
I am facing a situation like, I need to copy the individual data row along with the header row in a separate sheets.
Please find attached the sample file.
Can someone help me on this.
Appreciate your help.
Thanks,
aganesan99
Hi,
I am facing a situation like, I need to copy the individual data row along with the header row in a separate sheets.
Please find attached the sample file.
Can someone help me on this.
Appreciate your help.
Thanks,
aganesan99
Hello
Try this
![]()
Sub PagesByDescription() Dim rRange As Range, rCell As Range Dim wSheet As Worksheet Dim wSheetStart As Worksheet Dim strText As String Set wSheetStart = ActiveSheet wSheetStart.AutoFilterMode = False 'Set a range variable to the correct item column Set rRange = Range("A1", Range("A65536").End(xlUp)) 'Delete any sheet called "UniqueList" 'Turn off run time errors & delete alert On Error Resume Next Application.DisplayAlerts = False Worksheets("UniqueList").Delete 'Add a sheet called "UniqueList" Worksheets.Add().Name = "UniqueList" 'Filter the Set range so only a unique list is created With Worksheets("UniqueList") rRange.AdvancedFilter xlFilterCopy, , _ Worksheets("UniqueList").Range("A1"), True 'Set a range variable to the unique list, less the heading. Set rRange = .Range("A2", .Range("A65536").End(xlUp)) End With On Error Resume Next With wSheetStart For Each rCell In rRange strText = rCell .Range("A1").AutoFilter 1, strText Worksheets(strText).Delete 'Add a sheet named as content of rCell Worksheets.Add().Name = strText 'Copy the visible filtered range _ (default of Copy Method) and leave hidden rows .UsedRange.Copy Destination:=ActiveSheet.Range("A1") ActiveSheet.Cells.Columns.AutoFit Next rCell End With With wSheetStart .AutoFilterMode = False .Activate End With On Error GoTo 0 Application.DisplayAlerts = True End Sub
Regards
Fotis.
-This is my Greek whisper to Europe.
--Remember, saying thanks only takes a second or two. Click the little star * below, to give some Rep if you think an answer deserves it.
Advanced Excel Techniques: http://excelxor.com/
--KISS(Keep it simple Stupid)
--Bring them back.
---See about Acropolis of Athens.
--Visit Greece.
Thanks Fotis for your timely help
aganesan99
Hi Fotis,
I have a row above the header column and it is also getting copied.
I don't want that to happen. Can you help?
Thanks,
aganesan99
Maybe:
![]()
Sub aganesan99() Dim rcell As Range Dim ws As Worksheet Set ws = Sheets("Sheet1") ws.Activate For Each rcell In Range("A2:A" & Range("A" & Rows.count).End(3)(1).Row) Sheets.Add.Name = rcell.Value ActiveSheet.Rows(1).Value = ws.Rows(1).Value ActiveSheet.Rows(2).Value = ws.Rows(rcell.Row).Value ws.Activate Next rcell End Sub
Thanks Davis for your help. Great.
aganesan99
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks