View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Tea Tea is offline
external usenet poster
 
Posts: 1
Default Create New Sheets from Filtered List - help on macro

Hi all,



I would appreciate help with VBA.

I am trying to edit VBA macro for creating new sheets from filtered list,
and i am somewhat stuck.

I managed to edit macro so that it filters column 4, but i dont know how to
write few lines of code so that macro does the following:



a.. On created sheets, at the bottom of the last column with data, to
summarize the data. Name of that coloumn will always be 'Grand Total'
b.. On 'UniqueList' sheet, VBA should name coloumn B:'Grand Total', and
paste appropriate 'Grand Total' value
c.. On sheet 'UniqueList', in the cell at the bottom of coloumn B, grand
total for created sheets should be summarized.


Thx in advance,

Goran





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("d1", Range("d65536").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 4, 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