Delete Worksheet Condition
 

This macro is working wonderfully to populate multiple worksheets based on
the data in the "A-Rad" (ws1) worksheet. Now I would like to add a step
where I can delete any worksheets each time this changes. So, in other
words, I need to delete a worksheet if the distinct value in
ws1.Columns("A:A") < the current worksheet names. Would it be better to
delete all Worksheet Names < "A-Rad" and then update the worksheets with
this code? I will always need to keep "Set ws1 = Sheets("A-Rad")" since this
serves as the main data source.

I have tried and struggling with the proper syntax and placement within this
code to identify the Worksheet names < "A-Rad" and then delete those. Your
help is greatly appreciated.

Sub PopulateRadWorksheets()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("A-Rad")
Set rng = Range("AllRadiologists")
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

'extract a list of Radiologists
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 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("A-Rad").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("A-Rad").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Columns.AutoFit

End If

Next
ws1.Select
ws1.Columns("J:L").Delete
SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index < .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If

For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) UCase(Worksheets(M).Name) Then
Worksheets(N).Move Befo=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Befo=Worksheets(M)
End If
End If
Next N
Next M

End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

Delete Worksheet Condition
 

I am very proud of myself because I finally figured out how to incorporate
the deletion of all worksheets with the exception of the "A-Rad" worksheet.
My macro begins with this and then it updates and sorts after that.

'delete all the individual worksheets prior to updating with new data
Application.DisplayAlerts = False
For Each wks In Worksheets
If wks.Name < "A-Rad" Then wks.Delete
Next wks

"Vicki" wrote:

This macro is working wonderfully to populate multiple worksheets based on
the data in the "A-Rad" (ws1) worksheet. Now I would like to add a step
where I can delete any worksheets each time this changes. So, in other
words, I need to delete a worksheet if the distinct value in
ws1.Columns("A:A") < the current worksheet names. Would it be better to
delete all Worksheet Names < "A-Rad" and then update the worksheets with
this code? I will always need to keep "Set ws1 = Sheets("A-Rad")" since this
serves as the main data source.

I have tried and struggling with the proper syntax and placement within this
code to identify the Worksheet names < "A-Rad" and then delete those. Your
help is greatly appreciated.

Sub PopulateRadWorksheets()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("A-Rad")
Set rng = Range("AllRadiologists")
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

'extract a list of Radiologists
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 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("A-Rad").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("A-Rad").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Columns.AutoFit

End If

Next
ws1.Select
ws1.Columns("J:L").Delete
SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then
FirstWSToSort = 1
LastWSToSort = Worksheets.Count
Else
With ActiveWindow.SelectedSheets
For N = 2 To .Count
If .Item(N - 1).Index < .Item(N).Index - 1 Then
MsgBox "You cannot sort non-adjacent sheets"
Exit Sub
End If
Next N
FirstWSToSort = .Item(1).Index
LastWSToSort = .Item(.Count).Index
End With
End If

For M = FirstWSToSort To LastWSToSort
For N = M To LastWSToSort
If SortDescending = True Then
If UCase(Worksheets(N).Name) UCase(Worksheets(M).Name) Then
Worksheets(N).Move Befo=Worksheets(M)
End If
Else
If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
Worksheets(N).Move Befo=Worksheets(M)
End If
End If
Next N
Next M

End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function