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
|