Worksheet Sort
 

I have the following code to filter and create new worksheets based on one
worksheet with all of the raw data. How and where can I add code to sort all
of the new worksheets by their name in this macro?

Sub ExtractCodes()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("AllCrosswalkCodes")
Set rng = Range("CodesDatabase")

'refresh all codes data from the most current RIMS text file
Selection.QueryTable.Refresh BackgroundQuery:=False

'extract a list of Sales Reps
ws1.Columns("A:A").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("A1").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("AllCrosswalkCodes").Range(" L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Columns.AutoFit


Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("AllCrosswalkCodes").Range(" L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Columns.AutoFit
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

Worksheet Sort
 

You could call Chip Pearson's routine to do this:

http://www.cpearson.com/excel/sortws.htm

you could probably call it between these two lines:

ws1.Columns("J:L").Delete
SortWorksheets
End Sub

--
Regards,
Tom Ogilvy


"Vicki" wrote in message
...
I have the following code to filter and create new worksheets based on one
worksheet with all of the raw data. How and where can I add code to sort
all
of the new worksheets by their name in this macro?

Sub ExtractCodes()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("AllCrosswalkCodes")
Set rng = Range("CodesDatabase")

'refresh all codes data from the most current RIMS text file
Selection.QueryTable.Refresh BackgroundQuery:=False

'extract a list of Sales Reps
ws1.Columns("A:A").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("A1").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("AllCrosswalkCodes").Range(" L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Columns.AutoFit


Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("AllCrosswalkCodes").Range(" L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Columns.AutoFit
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

Worksheet Sort
 

Worked like a charm. Thank you so much!

"Tom Ogilvy" wrote:

You could call Chip Pearson's routine to do this:

http://www.cpearson.com/excel/sortws.htm

you could probably call it between these two lines:

ws1.Columns("J:L").Delete
SortWorksheets
End Sub

--
Regards,
Tom Ogilvy


"Vicki" wrote in message
...
I have the following code to filter and create new worksheets based on one
worksheet with all of the raw data. How and where can I add code to sort
all
of the new worksheets by their name in this macro?

Sub ExtractCodes()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("AllCrosswalkCodes")
Set rng = Range("CodesDatabase")

'refresh all codes data from the most current RIMS text file
Selection.QueryTable.Refresh BackgroundQuery:=False

'extract a list of Sales Reps
ws1.Columns("A:A").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("A1").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("AllCrosswalkCodes").Range(" L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Columns.AutoFit


Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("AllCrosswalkCodes").Range(" L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Columns.AutoFit
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