I have a sheet that is subtotaled by project and each project has
several rows. There is a column (G) which identifies the project. There
are over 35 projects on the sheet. What I want to do is pick 8 known
projects from the list and copy the identified rows associated with the
project to a new sheet. The projects are indentified by a project #
like 00-000-000-000-000. Any help would be appreciated. TIA

Greg

You can use an Advanced Filter to extract the data to a new worksheet.
There are instructions in Excel's Help, and he

http://www.contextures.com/xladvfilter01.html

Also, there's a sample workbook here that uses programming to create new
sheets, based on items in the master list. You could revise it to suit
your needs:

http://www.contextures.com/excelfiles.html

Under Filters, look for 'Update Sheets from Master'


GregR wrote:
I have a sheet that is subtotaled by project and each project has
several rows. There is a column (G) which identifies the project. There
are over 35 projects on the sheet. What I want to do is pick 8 known
projects from the list and copy the identified rows associated with the
project to a new sheet. The projects are indentified by a project #
like 00-000-000-000-000. Any help would be appreciated. TIA

Greg



--
Debra Dalgleish
Excel FAQ, Tips & Book List
http://www.contextures.com/tiptech.html

Deborah, thank you very much. I adapted your code and it works with one
small hitch. It wrote the projects to unique sheets, but it wrote all
the projects. I only need it for 8 projects. How would I adapt this
code to only include project 00-000-000-000-001 thru
00-000-000-000-008. These project numbers are only an example.

Option Explicit
Sub ExtractProjs()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("By Project")
Set rng = Range("DB")

Sheets("By Project").Select
Selection.RemoveSubtotal

'extract a list of projects
ws1.Columns("G:G").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("X1"), Unique:=True
r = Cells(Rows.Count, "X").End(xlUp).Row

'set up Criteria Area
Range("Z1").Value = Range("G1").Value

For Each c In Range("X2:X" & r)
'add the project name to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("By Project").Range("Z1:Z2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("X:Z").Delete

Sheets("By Project").Select
Selection.Subtotal GroupBy:=7, Function:=xlSum,
TotalList:=Array(22), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

End Sub

TIA. Greg

You could create a worksheet with a criteria list, and name it
CriteriaSheet. Name the list CriteriaList.

Then, using the code in my sample workbook, change it to refer to the
criteria list:

'=====================
Sub FilterCities()
'last edited March 18, 2004
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets("CriteriaSheet")

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("CriteriaList"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell


MsgBox "Data has been sent"

End Sub
'===================================

GregR wrote:
Deborah, thank you very much. I adapted your code and it works with one
small hitch. It wrote the projects to unique sheets, but it wrote all
the projects. I only need it for 8 projects. How would I adapt this
code to only include project 00-000-000-000-001 thru
00-000-000-000-008. These project numbers are only an example.

Option Explicit
Sub ExtractProjs()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("By Project")
Set rng = Range("DB")

Sheets("By Project").Select
Selection.RemoveSubtotal

'extract a list of projects
ws1.Columns("G:G").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("X1"), Unique:=True
r = Cells(Rows.Count, "X").End(xlUp).Row

'set up Criteria Area
Range("Z1").Value = Range("G1").Value

For Each c In Range("X2:X" & r)
'add the project name to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("By Project").Range("Z1:Z2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("X:Z").Delete

Sheets("By Project").Select
Selection.Subtotal GroupBy:=7, Function:=xlSum,
TotalList:=Array(22), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

End Sub

TIA. Greg



--
Debra Dalgleish
Excel FAQ, Tips & Book List
http://www.contextures.com/tiptech.html

Deborah, thank you very much. Works like a charm....................

Greg