macro filter

[puiuluipui]

Hi, can this macro be modified to save results in another sheets in the same
workbook? Now it's saving in many workbooks in "c:\temp\", but i need the
results to be saved in sheets in the same workbook.
Can this be done?
Thanks!


Sub MakeSupervisorBooks()

Folder = "c:\temp\"

'sort worksheet by Managers
LastRow = Range("C" & Rows.Count).End(xlUp).Row

With ThisWorkbook.ActiveSheet
.Rows("4:" & LastRow).Sort _
Key1:=.Range("C1"), _
Order1:=xlAscending, _
Header:=xlNo
RowCount = 4
FirstRow = RowCount 'firstrow is the first row for each supervisor
Do While .Range("C" & RowCount) <> "" 'loop until all the rows are
processed
'test when last row for supervisor is found
If .Range("C" & RowCount) <> .Range("C" & (RowCount + 1)) Then
Supervisor = .Range("C" & RowCount)
'Open new Workbook
Set NewBk = Workbooks.Add
Set NewSht = NewBk.ActiveSheet
NewSht.Name = Supervisor
'copy header row 3 to new workbook
.Rows(3).Copy Destination:=NewSht.Rows(1)
'copy employee rows to new workbook
.Rows(FirstRow & ":" & RowCount).Copy
NewSht.Rows(2).PasteSpecial Paste:=xlPasteValues
'save new workbook
NewBk.SaveAs Filename:=Folder & Supervisor & ".xls"
NewBk.Close
'Set firstrow to first row of next supervisor
FirstRow = RowCount + 1
End If

RowCount = RowCount + 1
Loop
End With
End Sub

 

[Bernie Deitrick]

Try this as your loop - just add the new book once, then add sheet to it:

Set NewBk = Workbooks.Add
Do While .Range("C" & RowCount) <> "" 'loop until all the rows are
processed
'test when last row for supervisor is found
If .Range("C" & RowCount) <> .Range("C" & (RowCount + 1)) Then
Supervisor = .Range("C" & RowCount)
'Open new Workbook
Set NewSht = NewBk.WorkSheets.Add
NewSht.Name = Supervisor
'copy header row 3 to new workbook
.Rows(3).Copy Destination:=NewSht.Rows(1)
'copy employee rows to new workbook
.Rows(FirstRow & ":" & RowCount).Copy
NewSht.Rows(2).PasteSpecial Paste:=xlPasteValues
'Set firstrow to first row of next supervisor
FirstRow = RowCount + 1
End If

RowCount = RowCount + 1
Loop

'Finally, save new workbook
NewBk.SaveAs Filename:=Folder & Supervisor & ".xls"
NewBk.Close


HTH,
Bernie
MS Excel MVP

 

[puiuluipui]

It's working!
Thanks allot!

"Bernie Deitrick" a scris:

 

[puiuluipui]

Hi Bernie, can you help me with one more thing? I dont want this code to
create another xls. I have a workbook already with many sheets and i neet to
run the code in sheet1 and the macro to copy rows to already created sheets.
I need the code to do exactly like it's doing now but to copy rows from the
workbook i am running the macro,to the same workbook and to copy to already
created sheets. Criteria is in "C" column, so if in "C" the macro is finding
"John", then to copy the row to "John" sheet, not to create a new sheet.

I am running the code from sheet1 "workbook db" and i need the macro to save
in all other sheets also in "workbook db".

Can this be done?
Thanks!

 

[Bernie Deitrick]

Don't use this line:
Set NewBk = Workbooks.Add

Then try this, to add the new data at the bottom of the existing sheet:

Do While .Range("C" & RowCount) <> ""
'loop until all the rows are processed
'test when last row for supervisor is found
If .Range("C" & RowCount) <> .Range("C" & (RowCount + 1)) Then
Supervisor = .Range("C" & RowCount)
'copy employee rows to new workbook
.Rows(FirstRow & ":" & RowCount).Copy
Worksheets(Supervisor).Cells(Rows.Count,1).End(xlUp). _
Offset(1,0).EntireRow.PasteSpecial Paste:=xlPasteValues
'Set firstrow to first row of next supervisor
FirstRow = RowCount + 1
End If
RowCount = RowCount + 1
Loop

HTH,
Bernie
MS Excel MVP