macro to filter

[puiuluipui]

Hi i have a maco and i need to change it a little bit? 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 corresponding sheets also in "workbook db".

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
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

End With
End Sub


Can this be done?
Thanks!

 

[Joel]

The code was creating a new workbook and then not putting anything in the new
workbook. I simply eliminated some lines by commenting them out. then
change the comments from new workbook to new worksheet.

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
' 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)
'Add new worksheet
Set NewSht = NewBk.Worksheets.Add
NewSht.Name = Supervisor
'copy header row 3 to new worksheet
.Rows(3).Copy Destination:=NewSht.Rows(1)
'copy employee rows to new worksheet
.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

End With
End Sub

 

[puiuluipui]

Hi Joel, i dont want the macro to save the file to "c:\temp\".
I dont want the file to be saved and i dont want the file to be closed at
the end.
I am working with just one workbook and i need the macro to copy rows to the
same workbook but in the corresponding sheets.
Criteria of this macro is in column "C".

I have something like this:
sheets: - sheet1 ; john; mary; jim; isabella...

column "C" in "sheet1":
john
isabella
jim
mary

All i need is the macro to copy from sheet1, rows with john to "john" sheet.
-rows with isabella to "isabella" sheet.
-rows with jim to "jim" sheet.
-rows with mary to "mary" sheet.

The code i gaved you, works, but is creating another xls and is creating
another sheets and i dont want that.
I want to work in just one workbook and to copy rows to existing sheets.
Can this be done? With this code or another?
Thanks!

 

[puiuluipui]

Hi Joel, i found this code. Can this be modify to add rows everytime i run
the code?
The code copy rows, but i need to add rows.
Can this be done?

module 1
Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

'set up Criteria Area
Range("L1").Value = Range("C1").Value

For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

module 2

Option Explicit

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 9/6/2003 by Dalgleish
'

'
End Sub


Thanks!

 

[Joel]

I had to make two changes

1) I forgot to change workbooks.add to worksheets.add

2) I made the following change

from
With ThisWorkbook.ActiveSheet
to
Set sht = ThisWorkbook.ActiveSheet
With sht

when a sheet is added it becomes the activesheet.


Sub MakeSupervisorBooks()

Folder = "c:\temp\"

'sort worksheet by Managers
LastRow = Range("C" & Rows.Count).End(xlUp).Row
Set sht = ThisWorkbook.ActiveSheet
With sht
.Rows("4:" & LastRow).Sort _
Key1:=.Range("C1"), _
Order1:=xlAscending, _
Header:=xlNo
RowCount = 4
FirstRow = RowCount 'firstrow is the first row for each supervisor
' 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)
'Add new worksheet
Set NewSht = ThisWorkbook.Sheets.Add
NewSht.Name = Supervisor
'copy header row 3 to new worksheet
.Rows(3).Copy Destination:=NewSht.Rows(1)
'copy employee rows to new worksheet
.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

End With
End Sub

 

[puiuluipui]

Hi Joel. Your code it's working in the same workbook, and it's creating
sheets for every entry. but if a sheet already exist with an entry name
("john"), than the macro is not working. i receive an error (400). If you can
modify the last code i send to you, to add rows, it will be great. This code
is doing exactly what i need, but is not adding rows, just copy rows. So,
this code it will be perfect for me if it will add rows everytime i run the
code.
Thanks so much for everything!

 

[Joel]

I recognize this code. It is mine. So I'm modifying my own code. IO can
tell because this line is my orignal code

FirstRow = RowCount



Sub MakeSupervisorBooks()

Folder = "c:\temp\"

'sort worksheet by Managers
LastRow = Range("C" & Rows.Count).End(xlUp).Row
Set oldsht = ThisWorkbook.ActiveSheet
With oldsht
.Rows("4:" & LastRow).Sort _
Key1:=.Range("C1"), _
Order1:=xlAscending, _
Header:=xlNo
RowCount = 4
FirstRow = RowCount 'firstrow is the first row for each supervisor

FirstRow = RowCount
Do While .Range("C" & RowCount) <> "" 'loop until all the rows are
'processed
If .Range("C" & RowCount) <> .Range("C" & (RowCount + 1)) Then
Supervisor = .Range("C" & RowCount)

'look for worksheet
found = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = Supervisor Then
found = True
Exit For
End If
Next sht

If found = True Then
Set SupSht = sht
LastRow = SupSht.Range("C" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
Else
'Add new worksheet

Set SupSht = ThisWorkbook.Sheets _
.Add(after:=Sheets(Sheets.Count))
SupSht.Name = Supervisor
'copy header row 3 to new worksheet
.Rows(3).Copy Destination:=SupSht.Rows(1)
NewRow = 2

End If

'copy employee rows to new worksheet
.Rows(FirstRow & ":" & RowCount).Copy
SupSht.Rows(NewRow).PasteSpecial Paste:=xlPasteValues
'Set firstrow to first row of next supervisor
FirstRow = RowCount + 1
End If

RowCount = RowCount + 1
Loop

End With
End Sub