Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
Hi, i found this code. It's almost exactly what i need. This code copy rows.
What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
Hi Bob, i receive :
Run-time error '1004': Method 'Range' of object'_Global' failed I hit "debug" and and this is the error that is found: "Set rng = Range("Database")" What am i doing wrong? Thanks! "Bob Phillips" wrote: 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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
Sorry Bob, it's working, the error was mine. But is still not adding any
entries after i run the code again. The code copy rows the first time i run the code and replace etries the second time i run the code. I need to add rows everytime i run the code. So if i run the code 2 times i need to have double rows in destination sheet. Can this be done? Thanks! "Bob Phillips" wrote: 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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
See if this is any better
Sub ExtractReps() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim rng As Range Dim r As Integer Dim c As Range Dim NextRow 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 Set ws2 = Sheets(c.Value) Else Set ws2 = Sheets.Add End If With ws2 .Move After:=Worksheets(Worksheets.Count) .Name = c.Value If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Sorry Bob, it's working, the error was mine. But is still not adding any entries after i run the code again. The code copy rows the first time i run the code and replace etries the second time i run the code. I need to add rows everytime i run the code. So if i run the code 2 times i need to have double rows in destination sheet. Can this be done? Thanks! "Bob Phillips" wrote: 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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#8
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
Hi Bob, many many thanks!!! It's working great! This is what i need! I have
though, another question. I promiss is the last one. Can the code save to an initials sheet? I have so many sheets and it uses a lot of space. In column "C" i have names, and the corresponding sheets to be names initials. And initials to be my choise. Ex: name sheet John B J. B. Mary C M.C. Eduard E E.E. Anderson S A.S. Can this be done? Thanks!! You've made me very happy! Thanks! "Bob Phillips" wrote: See if this is any better Sub ExtractReps() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim rng As Range Dim r As Integer Dim c As Range Dim NextRow 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 Set ws2 = Sheets(c.Value) Else Set ws2 = Sheets.Add End If With ws2 .Move After:=Worksheets(Worksheets.Count) .Name = c.Value If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Sorry Bob, it's working, the error was mine. But is still not adding any entries after i run the code again. The code copy rows the first time i run the code and replace etries the second time i run the code. I need to add rows everytime i run the code. So if i run the code 2 times i need to have double rows in destination sheet. Can this be done? Thanks! "Bob Phillips" wrote: 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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#9
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
I need the code to do exactly like you make it. It's beautiful. The only
change if posible is to save to some designated sheets. In column "C" i have names. Your code is saving to sheets. Sheets name is given by names in column "C". If in "C5" the code found "John", then the code is adding that row to a sheet named "John". This is what your code is doing now. The only change i need is that when the code is finding "John in "C5", then the code to add that row to a sheet named "J" or anything i whant. Sorry for my poor english. EX: -now your code is adding like this: "C" column below row goes to this sheet sheets name 1 John John 2 Mary Mary 3 Anderson Anderson --John row is add to a sheet. Sheet name is given by criteria in "C" column (John)-- --Mary row is add to a sheet. Sheet name is given by criteria in "C" column (Mary)-- --Anderson row is add to a sheet. Sheet name is given by criteria in "C" column (Anderson)-- EX--i need your code to do like this: "C" column below row goes to this sheet sheets name 1 John J 2 Mary M 3 Anderson A --John row is add to a sheet. Sheet name to be "J" --Mary row is add to a sheet. Sheet name to be "M" --Anderson row is add to a sheet. Sheet name to be "A" i need to have control to where a row is going. Thanks allot! I really hope you can help me with this! Thanks! "Bob Phillips" wrote: Save what exactly to the initials sheet? -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi Bob, many many thanks!!! It's working great! This is what i need! I have though, another question. I promiss is the last one. Can the code save to an initials sheet? I have so many sheets and it uses a lot of space. In column "C" i have names, and the corresponding sheets to be names initials. And initials to be my choise. Ex: name sheet John B J. B. Mary C M.C. Eduard E E.E. Anderson S A.S. Can this be done? Thanks!! You've made me very happy! Thanks! "Bob Phillips" wrote: See if this is any better Sub ExtractReps() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim rng As Range Dim r As Integer Dim c As Range Dim NextRow 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 Set ws2 = Sheets(c.Value) Else Set ws2 = Sheets.Add End If With ws2 .Move After:=Worksheets(Worksheets.Count) .Name = c.Value If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Sorry Bob, it's working, the error was mine. But is still not adding any entries after i run the code again. The code copy rows the first time i run the code and replace etries the second time i run the code. I need to add rows everytime i run the code. So if i run the code 2 times i need to have double rows in destination sheet. Can this be done? Thanks! "Bob Phillips" wrote: 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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
#10
Posted to microsoft.public.excel.misc
|
|||
|
|||
macro add
Hi Bob, maybe this is easier. Can you insert a small code so when this code
create a sheet to add "A" to sheet name? Ex: Now is saving to a sheet named "John" I need the code to save to a sheet named "A John"..."A Mary"...etc All the sheets to have "A" in front of names. The same when the code is creating a new sheet. To create a sheet by criteria in "C" column (like is doing now), but to add "A" in front of the names. Either is adding to an existing sheet or is creating a new sheet, i need the code to put "A" in front of sheets names. Can this be done? Thanks a million times! "Bob Phillips" wrote: Save what exactly to the initials sheet? -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi Bob, many many thanks!!! It's working great! This is what i need! I have though, another question. I promiss is the last one. Can the code save to an initials sheet? I have so many sheets and it uses a lot of space. In column "C" i have names, and the corresponding sheets to be names initials. And initials to be my choise. Ex: name sheet John B J. B. Mary C M.C. Eduard E E.E. Anderson S A.S. Can this be done? Thanks!! You've made me very happy! Thanks! "Bob Phillips" wrote: See if this is any better Sub ExtractReps() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim rng As Range Dim r As Integer Dim c As Range Dim NextRow 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 Set ws2 = Sheets(c.Value) Else Set ws2 = Sheets.Add End If With ws2 .Move After:=Worksheets(Worksheets.Count) .Name = c.Value If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Sorry Bob, it's working, the error was mine. But is still not adding any entries after i run the code again. The code copy rows the first time i run the code and replace etries the second time i run the code. I need to add rows everytime i run the code. So if i run the code 2 times i need to have double rows in destination sheet. Can this be done? Thanks! "Bob Phillips" wrote: 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 With wsNew .Move After:=Worksheets(Worksheets.Count) .Name = c.Value Dim NextRow If .Range("A1").Value = "" Then NextRow = 1 ElseIf .Range("A2").Value = "" Then NextRow = 2 Else NextRow = .Range("A1").End(xlDown).Row + 1 End If rng.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _ CopyToRange:=.Cells(NextRow, "A"), _ Unique:=False End With 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 -- __________________________________ HTH Bob "puiuluipui" wrote in message ... Hi, i found this code. It's almost exactly what i need. This code copy rows. What i need is to add rows everytime i run the code. Can this be done? Thanks! 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macro Help Needed - Excel 2007 - Print Macro with Auto Sort | Excel Worksheet Functions | |||
My excel macro recorder no longer shows up when recording macro | Excel Discussion (Misc queries) | |||
Macro needed to Paste Values and prevent Macro operation | Excel Discussion (Misc queries) | |||
Macro needed to Paste Values and prevent Macro operation | Excel Discussion (Misc queries) |