macro add

[puiuluipui]

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

 

[Bob Phillips]

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

 

[puiuluipui]

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!

 

[puiuluipui]

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!

 

[Don Guillett]

Bob is referring to either an already created defined name range or telling
you to input your range there

 

[puiuluipui]

Hi Don. i found you everywere. You are my guardian angel.
So...That error was mine.
I really need to make this work and i was on the run.
The code is working but is not adding rows. I need to add rows everytime i
run the code.
Can this code be modified to add rows everytime i run the code?
Thanks again Don!

 

[Bob Phillips]

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

 

[puiuluipui]

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]

Save what exactly to the initials sheet?

 

[puiuluipui]

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!

 

[puiuluipui]

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!