Use loop to filter, copy/paste to new sheet; run through entire li
 

How can I filter all items on a sheet named 'Summary Sheet' in Column C, then
run a macro?

I already have the macro, which calculates unique items on Row 3; will just
call it here.

Finally, copy paste the results from the filtered list and Row 3, to a sheet
named €˜Rep Summary, skip a row for the next copy/paste procedure, then loop
back to the beginning and do it again until I have done this for every item
in the list? This seems to be harder than I initially thought...

Thanks,
Ryan---


--
RyGuy

Use loop to filter, copy/paste to new sheet; run through entire li
 

This code will create a sheet for each unique name. You will need to
change the data range & Field to suit your spreadsheet


Code:
--------------------
'Option Explicit

'---------------------------------------------------------------------------------------
' Module : Module1
' DateTime : 24/09/2006 22:48
' Author : Roy Cox (royUK)
' Website : more examples
' Purpose : Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
' projects but please leave this header intact.
'---------------------------------------------------------------------------------------

Sub ExtractToSheets()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rData As Range
Dim rCl As Range
Dim sNm As String
Set ws = Sheet1

'extract a list of unique names
'first clear existing list
With ws
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 9).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
sNm = rCl.Text
'add new sheet (only if required-NB uses UDF)
If WksExists(sNm) Then
'so clear contents
Sheets(sNm).Cells.Clear
Else
'new sheet required
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
wsNew.Name = sNm
End If
'AutoFilter & copy to relevant sheet
rData.AutoFilter Field:=3, Criteria1:=sNm
rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
Next rCl
End With
ws.Columns(Columns.Count).ClearContents 'remove temporary list
rData.AutoFilter 'switch off AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function
--------------------


--
royUK

Hope that helps, RoyUK
For tips & examples visit my 'web site
' (http://www.excel-it.com)
------------------------------------------------------------------------
royUK's Profile: http://www.thecodecage.com/forumz/member.php?userid=15
View this thread: http://www.thecodecage.com/forumz/sh...ad.php?t=33781

Use loop to filter, copy/paste to new sheet; run through entir
 

That code is great! I've seen something similar on Ron de Bruin's site. The
only problem with that is that I get over 300 sheets when I run this kind of
code. I was hoping to fund some kind of solution that summarizes the
information, on one single sheet, rather than giving me many, many,many
sheets to deal with.

Any other ideas?

Thanks,
Ryan---
--
RyGuy


"royUK" wrote:


This code will create a sheet for each unique name. You will need to
change the data range & Field to suit your spreadsheet


Code:
--------------------
'Option Explicit

'---------------------------------------------------------------------------------------
' Module : Module1
' DateTime : 24/09/2006 22:48
' Author : Roy Cox (royUK)
' Website : more examples
' Purpose : Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
' projects but please leave this header intact.
'---------------------------------------------------------------------------------------

Sub ExtractToSheets()
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim rData As Range
Dim rCl As Range
Dim sNm As String
Set ws = Sheet1

'extract a list of unique names
'first clear existing list
With ws
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 9).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
sNm = rCl.Text
'add new sheet (only if required-NB uses UDF)
If WksExists(sNm) Then
'so clear contents
Sheets(sNm).Cells.Clear
Else
'new sheet required
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
wsNew.Name = sNm
End If
'AutoFilter & copy to relevant sheet
rData.AutoFilter Field:=3, Criteria1:=sNm
rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
Next rCl
End With
ws.Columns(Columns.Count).ClearContents 'remove temporary list
rData.AutoFilter 'switch off AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function
--------------------


--
royUK

Hope that helps, RoyUK
For tips & examples visit my 'web site
' (http://www.excel-it.com)
------------------------------------------------------------------------
royUK's Profile: http://www.thecodecage.com/forumz/member.php?userid=15
View this thread: http://www.thecodecage.com/forumz/sh...ad.php?t=33781