AdrianK
02-25-2008, 09:59 AM
Hi there,
I am using the below code in a macro to extract unique records from a database extract onto a new sheet, which works fine, however I am encountering problems where each sheet then needs to have individual formatting performed once this function has run (subtotals, headers, print areas etc.) however, as the names and number of sheets is different each time the macro runs I am finding this difficult, and getting a lot of errors.
Is there a way that each sheet can be selected, have the formatting performed on it, and and then the next sheet selected until the end, without referring to the names or the number of sheets, as these are constantly changing?
Public Sub Unique_Record_Extract()
'extracts unique records from Column A and copies those records to a new worksheet
Dim My_Range As Range
Dim My_Cell As Variant
Dim sh_Original As Worksheet
Dim cl As Variant
'turn off interactive stuff to speed it up
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Rename the first sheet to generic name "Data"
Worksheets(1).Name = "Data"
'add a new worksheet to temporarily store unique record names
Set sh_Original = ActiveSheet
On Error Resume Next
Sheets("TEMPXXX").Delete
On Error GoTo 0
Worksheets.Add
ActiveSheet.Name = "TEMPXXX"
'copy all unique records from main sheet into temporary sheet
Worksheets("Data").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Columns("A:A"), Unique:=True
'set up list of unique records stored on the temporary sheet
'start in cell A2 because the advanced filter will copy headers too.
Set My_Range = Range("A2:A" & Range("A65536").End(xlUp).Row)
'cycle through each unique entry in the list and filter the original sheet with that value
For Each My_Cell In My_Range
'create a new worksheet with unique record name (delete it first if it aleady exists)
On Error Resume Next
Sheets(My_Cell.Value).Delete 'delete if already exists
On Error GoTo 0
Worksheets.Add 'add new sheet which subsequently becomes the active sheet
ActiveSheet.Name = My_Cell.Value ' be careful here of worksheet names > 31 characters
'filter Original sheet
sh_Original.UsedRange.AutoFilter Field:=1, Criteria1:=My_Cell.Value
'copied filter list to the activesheet (which is the sheet just recently added)
sh_Original.Cells.SpecialCells(xlVisible).Copy Destination:=Range("A1")
'autofit the columns to make it look pretty
Columns.AutoFit
'remove blank cells
Range("A1").Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Clear
Range("A1").Select
Next
'tidy up!
Worksheets("TEMPXXX").Delete
sh_Original.AutoFilterMode = False
Set sh_Original = Nothing
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Any help would be greatly appreciated.
Many thanks
AK
I am using the below code in a macro to extract unique records from a database extract onto a new sheet, which works fine, however I am encountering problems where each sheet then needs to have individual formatting performed once this function has run (subtotals, headers, print areas etc.) however, as the names and number of sheets is different each time the macro runs I am finding this difficult, and getting a lot of errors.
Is there a way that each sheet can be selected, have the formatting performed on it, and and then the next sheet selected until the end, without referring to the names or the number of sheets, as these are constantly changing?
Public Sub Unique_Record_Extract()
'extracts unique records from Column A and copies those records to a new worksheet
Dim My_Range As Range
Dim My_Cell As Variant
Dim sh_Original As Worksheet
Dim cl As Variant
'turn off interactive stuff to speed it up
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Rename the first sheet to generic name "Data"
Worksheets(1).Name = "Data"
'add a new worksheet to temporarily store unique record names
Set sh_Original = ActiveSheet
On Error Resume Next
Sheets("TEMPXXX").Delete
On Error GoTo 0
Worksheets.Add
ActiveSheet.Name = "TEMPXXX"
'copy all unique records from main sheet into temporary sheet
Worksheets("Data").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Columns("A:A"), Unique:=True
'set up list of unique records stored on the temporary sheet
'start in cell A2 because the advanced filter will copy headers too.
Set My_Range = Range("A2:A" & Range("A65536").End(xlUp).Row)
'cycle through each unique entry in the list and filter the original sheet with that value
For Each My_Cell In My_Range
'create a new worksheet with unique record name (delete it first if it aleady exists)
On Error Resume Next
Sheets(My_Cell.Value).Delete 'delete if already exists
On Error GoTo 0
Worksheets.Add 'add new sheet which subsequently becomes the active sheet
ActiveSheet.Name = My_Cell.Value ' be careful here of worksheet names > 31 characters
'filter Original sheet
sh_Original.UsedRange.AutoFilter Field:=1, Criteria1:=My_Cell.Value
'copied filter list to the activesheet (which is the sheet just recently added)
sh_Original.Cells.SpecialCells(xlVisible).Copy Destination:=Range("A1")
'autofit the columns to make it look pretty
Columns.AutoFit
'remove blank cells
Range("A1").Select
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Clear
Range("A1").Select
Next
'tidy up!
Worksheets("TEMPXXX").Delete
sh_Original.AutoFilterMode = False
Set sh_Original = Nothing
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Any help would be greatly appreciated.
Many thanks
AK