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
|