Any ideas on how to do this?

[michael.beckinsale]

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

 

[Die_Another_Day]

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]

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

 

[Die_Another_Day]

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(xlCellTypeVisible).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

 

[Die_Another_Day]

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(xlCellTypeVisible).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

 

[michael.beckinsale]

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

 

[Die_Another_Day]

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]

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