| 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
|
|
#6
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 |
| 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) | |||
Hybrid Mode
