Hi Adam
This code will do it pretty quick. You need to run it from your sheet will All sectors on. It will put a list of unique sectors in Column E, filter your table down by sectors and copy visible cells in Column A:D and paste them on a sheet created and named after each sector. You simply need to change the ranges to suit.
Sub CopySectors()
'Copy text only from Column A
'Written by OzGrid Business Applications
'www.ozgrid.com
Dim i As Integer
Dim ThisSheet As Worksheet
Dim Sector As String
Application.ScreenUpdating = False
Set ThisSheet = ActiveSheet
With ThisSheet
'Turn off AutoFilters
.AutoFilterMode = False
'Filter out all unique sectors _
and put them in Column E
.Columns(2).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:= _
.Range("E1"), Unique:=True
'Loop through and filter by all unique sectors _
then create a worsheet named after each sector.
'Then copy the data for that sector to it's sheet
For i = 2 To WorksheetFunction.CountA(.Columns("E:E"))
Sector = .Cells(i, 5)
'Turn on Autofilter if needed
If .AutoFilterMode = False Then .Rows(1).AutoFilter
'Filter down by sector and copy visible cells _
of columns A:D
.Rows(1).AutoFilter Field:=2, Criteria1:=Sector
.Columns("A:D").SpecialCells(xlVisible).Copy
'Add a sheet named after sector
Sheets.Add().Name = Sector
'Paste new data on sheet
ActiveSheet.Paste
Next i
.AutoFilterMode = False
End With
Set ThisSheet = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Dave
OzGrid Business Applications
Dave,
The code is very efficient. The problem is that I need to paste all because I want to formulas to copy over. The paste line takes a few minutes each time to just go over that one line. I have about 75 columns and They are mostly index formulas.
Adam
'Turn on Autofilter if needed If .AutoFilterMode = False Then .Rows(1).AutoFilter 'Filter down by sector and copy visible cells _ of columns A:D .Rows(1).AutoFilter Field:=2, Criteria1:=Sector .Columns("A:D").SpecialCells(xlVisible).Copy 'Add a sheet named after sector Sheets.Add().Name = Sector 'Paste new data on sheet ActiveSheet.Paste .AutoFilterMode = False
Dave I am getting a memory error after about the 7th or 8th sheet. is there any way of getting around this ??
Thanks,
Adam
, 'Turn on Autofilter if needed If .AutoFilterMode = False Then .Rows(1).AutoFilter 'Filter down by sector and copy visible cells _ of columns A:D .Rows(1).AutoFilter Field:=2, Criteria1:=Sector .Columns("A:D").SpecialCells(xlVisible).Copy 'Add a sheet named after sector Sheets.Add().Name = Sector 'Paste new data on sheet ActiveSheet.Paste .AutoFilterMode = False
Hi Adam
I a bit confused with your first comment about having to copy over formulas as well. The code WILL copy over formulas, formatting and content.
Regarding the "out of memory problem" I just tested the code again on a sheet with 30 different sectors and it ran without any memory problems and took about 10 seconds to complete.
Read this information below regarding memory problems:
Don't save the Workbooks in multiple formats unless really needed. Saving Workbooks as more than one format ( 95,97 and 97 ) can blow out file size by > 75%
Also see this article on OUTLOOK http://support.microsoft.com/support/kb/articles/Q167/0/81.ASP
Only have the "Add-ins" you need installed
If your using VBA then NOT releasing Objects from memory is another cause, always set them to nothing on completion:
Set Wsht as Worksheet(1)
Your code
Set Wsht =Nothing
Another big cause of problems is out of date Printer drivers make sure you have the latest. You can do this by going to the Website of your printer manufacture.
See this article: http://support.microsoft.com/support/kb/articles/Q165/9/85.ASP
Keeping the sheet zoom at 100% can also be helpful
And last but by no means least, delete all Temp files, Do a scan disk, empty the re-cycle bin then do a disk de-frag and re-boot.
Dave
OzGrid Business Applications