Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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! |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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" wrote: 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! |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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! "Joel" wrote: 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" wrote: 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! |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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" wrote: 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" wrote: 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! |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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" wrote: 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! "Joel" wrote: 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" wrote: 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! |
#6
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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" wrote: 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" wrote: 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! "Joel" wrote: 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" wrote: 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! |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro to filter
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 "puiuluipui" wrote: 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" wrote: 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" wrote: 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! "Joel" wrote: 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" wrote: 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! |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
macro filter | Excel Discussion (Misc queries) | |||
Macro Filter | Excel Worksheet Functions | |||
how can this filter be done in a macro? | Excel Discussion (Misc queries) | |||
Do i use a filter or a macro? | Excel Discussion (Misc queries) | |||
Need a filter macro | Excel Discussion (Misc queries) |