Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
Hi All,
I have a worksheet with approx 63000 rows of imported data populating columns A to L. The data is sorted so that the Column A criteria are all grouped in consecutive rows. The number of consecutive rows for the criteria range from approx 20 to 2000. Column A contains the criteria and for each criteria l want to: 1) create a new worksheet with that name 2) copy and paste all the data from the rows in which column A matches the criteria 3) always copy row1 to the new worksheet (header info) I would really like to do this in VBA since there are approx 140 unique values in column A ie 140 worksheets!, and l really do not fancy doing this by hand! Hope this makes sense, if you need any further info pls post. All help gratefully appreciated. Regards Michael Beckinsale |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
I don't have time to figure it all out but start by turn on the macro
recorded, use auto filtering, Copy, insert sheet and see where that gets you. Post back if you need help. I try to get to it in a hour or 2. Die_Another_Day michael.beckinsale wrote: Hi All, I have a worksheet with approx 63000 rows of imported data populating columns A to L. The data is sorted so that the Column A criteria are all grouped in consecutive rows. The number of consecutive rows for the criteria range from approx 20 to 2000. Column A contains the criteria and for each criteria l want to: 1) create a new worksheet with that name 2) copy and paste all the data from the rows in which column A matches the criteria 3) always copy row1 to the new worksheet (header info) I would really like to do this in VBA since there are approx 140 unique values in column A ie 140 worksheets!, and l really do not fancy doing this by hand! Hope this makes sense, if you need any further info pls post. All help gratefully appreciated. Regards Michael Beckinsale |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
Hi, Die_Another_Day Thanks for the feedback. I was thinking of going the filter / copy route but thought that with the number of rows involved it would probably be inefficient especially as the filter would have to be applied / removed approx 140 times. Additionally it would mean creating a list of unique criteria and looping through them. However it is a 'one-off' exercise, so maybe. The above aside there must be a more elegant solution. If you get time to consider the problem later l would be very grateful. Regards Michael Beckinsale |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
Actually I thought using autofilter was more efficient in that we are
not scrolling through every line. anyhow here's the code: Option Explicit Dim UniqueValues As New Collection Function CountUniqueValues(InputRange As Range) As Long Dim cl As Range On Error Resume Next ' ignore any errors For Each cl In InputRange If cl.Value < "" Then UniqueValues.Add cl.Value, CStr(cl.Value) ' add the unique item Next cl On Error GoTo 0 CountUniqueValues = UniqueValues.Count End Function Sub FilterNames() 'Macro written 21_July_2006 By Die_Another_Day Dim i As Long Dim uCnt As Long 'Unique Values count Dim hWS As Worksheet 'Home Worksheet Dim nWS As Worksheet 'New Worksheet Application.ScreenUpdating = False Set hWS = ActiveSheet uCnt = CountUniqueValues(Range("A2", Range("A2").End(xlDown))) Range("A1").AutoFilter For i = 1 To uCnt Range("A1").AutoFilter Field:=1, Criteria1:=UniqueValues(i) Range("A1").CurrentRegion.SpecialCells(xlCellTypeV isible).Copy Set nWS = Worksheets.Add nWS.Name = UniqueValues(i) nWS.Range("A1").PasteSpecial xlPasteAll hWS.Activate Application.CutCopyMode = False Next Range("A1").AutoFilter Application.ScreenUpdating = True End Sub HTH Die_Another_Day michael.beckinsale wrote: Hi, Die_Another_Day Thanks for the feedback. I was thinking of going the filter / copy route but thought that with the number of rows involved it would probably be inefficient especially as the filter would have to be applied / removed approx 140 times. Additionally it would mean creating a list of unique criteria and looping through them. However it is a 'one-off' exercise, so maybe. The above aside there must be a more elegant solution. If you get time to consider the problem later l would be very grateful. Regards Michael Beckinsale |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
Here's a new version modified to allow for blank rows.
Option Explicit Dim UniqueValues As New Collection Function CountUniqueValues(InputRange As Range) As Long Dim cl As Range On Error Resume Next ' ignore any errors For Each cl In InputRange If cl.Value < "" Then UniqueValues.Add cl.Value, CStr(cl.Value) ' add the unique item Next cl On Error GoTo 0 CountUniqueValues = UniqueValues.Count End Function Function FindLastCell() As Range Dim LastColumn As Integer Dim LastRow As Long Dim LastCell As Range If WorksheetFunction.CountA(Cells) 0 Then 'Search for any entry, by searching backwards by Rows. LastRow = Cells.Find(What:="*", After:=[A1], _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row 'Search for any entry, by searching backwards by Columns. LastColumn = Cells.Find(What:="*", After:=[A1], _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious).Column Set FindLastCell = Cells(LastRow, LastColumn) Else Set FindLastCell = Range("A1") End If End Function Sub FilterNames() 'Macro written 21_July_2006 By Die_Another_Day Dim i As Long Dim uCnt As Long 'Unique Values count Dim hWS As Worksheet 'Home Worksheet Dim nWS As Worksheet 'New Worksheet Dim lCell As Range 'Last Cell Dim fRange As Range 'Filter Range Application.ScreenUpdating = False Set hWS = ActiveSheet Set lCell = FindLastCell Set fRange = Range("A1", lCell) uCnt = CountUniqueValues(fRange.Columns(1)) fRange.AutoFilter For i = 1 To uCnt fRange.AutoFilter Field:=1, Criteria1:=UniqueValues(i) Range("A1").CurrentRegion.SpecialCells(xlCellTypeV isible).Copy Set nWS = Worksheets.Add nWS.Name = UniqueValues(i) nWS.Range("A1").PasteSpecial xlPasteAll hWS.Activate Application.CutCopyMode = False Next fRange.AutoFilter Application.ScreenUpdating = True End Sub HTH Die_Another_Day |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
Hi,
Die_Another_Day Many thanks for your code. I have not tried it yet because l was working on my own code without using the filter technique. The code, which does work, is pasted below. I created the list of unique criteria using the advanced filter. I have now been told that this is not a 'one-off' exercise so l will try your code and use whichever is the most efficient. Many, many thanks for all your help Sub Test() Dim tabname As String Dim startrow As Integer Dim endrow As Integer Sheets("A&O List - Unique Prisons").Activate Range("A2").Activate For i = 1 To 138 tabname = ActiveCell.Value Sheets.Add ActiveSheet.Name = tabname Sheets("Full A&O List").Range("A1:L1").Copy Destination:=Sheets(tabname).Range("A1") Sheets("Full A&O List").Activate Range("A1").Activate startrow = Cells.Find(What:=tabname, After:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Row Range("A65536").Activate endrow = Cells.Find(What:=tabname, After:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False).Row Range("A" & startrow & ":L" & endrow).Copy Destination:=Sheets(tabname).Range("A2") Sheets("A&O List - Unique Prisons").Activate ActiveCell.Offset(1, 0).Activate Next i End Sub Reagrds, Michael Beckinsale |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
just of note. with my code you don't have to create another sheet. I
also set application.screenupdating to false to speed up the process. Your code will only look for 138 unique entrys, no less no more. Is that ok? Die_Another_Day michael.beckinsale wrote: Hi, Die_Another_Day Many thanks for your code. I have not tried it yet because l was working on my own code without using the filter technique. The code, which does work, is pasted below. I created the list of unique criteria using the advanced filter. I have now been told that this is not a 'one-off' exercise so l will try your code and use whichever is the most efficient. Many, many thanks for all your help Sub Test() Dim tabname As String Dim startrow As Integer Dim endrow As Integer Sheets("A&O List - Unique Prisons").Activate Range("A2").Activate For i = 1 To 138 tabname = ActiveCell.Value Sheets.Add ActiveSheet.Name = tabname Sheets("Full A&O List").Range("A1:L1").Copy Destination:=Sheets(tabname).Range("A1") Sheets("Full A&O List").Activate Range("A1").Activate startrow = Cells.Find(What:=tabname, After:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Row Range("A65536").Activate endrow = Cells.Find(What:=tabname, After:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _ MatchCase:=False, SearchFormat:=False).Row Range("A" & startrow & ":L" & endrow).Copy Destination:=Sheets(tabname).Range("A2") Sheets("A&O List - Unique Prisons").Activate ActiveCell.Offset(1, 0).Activate Next i End Sub Reagrds, Michael Beckinsale |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Any ideas on how to do this?
Hi,
Die_Another_Day Your right of course but the code l posted was the 'test' version as denoted by the macro name. On testing l only looped 20 times and realised that l needed to turn the screen updating off. On the final version l have determined the lastrow with code and also amended the variable type as long to accomodate the 63000 rows. Its newsgroups like this that really allow developers to swap ideas and produce good robust applications for the end user. Once again many thanks for all your input Regards Michael Beckinsale |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Anyone else have any ideas?? | Excel Discussion (Misc queries) | |||
Any Ideas? | Excel Worksheet Functions | |||
Any Ideas | Excel Discussion (Misc queries) | |||
Any ideas? | Excel Programming | |||
Any ideas? | Excel Programming |