Sub QuietlyKill _
(sTab As Worksheet)
'v1.10 30 Aug 2018
'Deletes A Worksheet Without Displaying Alert
'Crafted 15 Mar 2018 by Jason B White
Dim booAlertsDisplayed As Boolean
booAlertsDisplayed = Application.DisplayAlerts
Application.DisplayAlerts = False
sTab.Delete
Application.DisplayAlerts = booAlertsDisplayed
End Sub
Sub SortFilterDelete _
(wSheet As Worksheet, sCol As String, _
sAct As String, sCriteria As String)
'v1.55 24 Feb 2023
'Crafted 17 Feb 2016 by Jason B White
'Declare Variables
Dim lngColumn As Long
Dim lngLastRow As Long
Dim lngMatches As Long
Dim strCrit As String
Dim rngCol As Range
lngColumn = Range(sCol & "1").Column
With wSheet
.Activate
'Set Variable Values
lngLastRow = .Cells _
(Rows.Count, lngColumn).End(xlUp).Row
Set rngCol = Range _
(.Cells(2, lngColumn), .Cells(lngLastRow, lngColumn))
Select Case sAct
Case Is = "Keep"
strCrit = "<>" & sCriteria
Case Is = "Delete"
strCrit = "=" & sCriteria
End Select
'Determine How Many Records Match Deletion Criteria
lngMatches = WorksheetFunction _
.CountIf(rngCol, sCriteria)
If lngMatches > 0 Then
With .AutoFilter.Sort
.SortFields.Clear
.SortFields.Add _
Key:=rngCol, _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Orientation = xlTopToBottom
.Apply
End With
.Cells.AutoFilter Field:=lngColumn, _
Criteria1:=strCrit
On Error Resume Next
rngCol.SpecialCells(xlCellTypeVisible) _
.EntireRow.Delete
On Error GoTo 0
.Cells.AutoFilter Field:=lngColumn
End If
End With
Set rngCol = Nothing
End Sub
Sub SianCCodeFactory()
'Crafted 13 Mar 2023 by Wookiee At MrExcel.com
'Declare Variables
Dim lngLastRow As Long
Dim lngLoop As Long
Dim lngLoop2 As Long
Dim strLevel As String
Dim strName As String
Dim arrNames As Variant
Dim arrSheets As Variant
Dim rngCells As Range
Dim wksCopy As Worksheet
Dim wksMaster As Worksheet
Dim wksOutput As Worksheet
Set wksMaster = ActiveSheet
With wksMaster
Application.ScreenUpdating = False
'Get List Of Unique Names
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("Q1").Formula2R1C1 = _
"=SORT(UNIQUE(R2C3:R" & lngLastRow & "C3))"
lngLastRow = .Cells(.Rows.Count, "Q").End(xlUp).Row
Set rngCells = .Range("Q1:Q" & lngLastRow)
arrNames = .Range("Q1:Q" & lngLastRow).Value
rngCells.ClearContents
'Copy Each Name To New Workbook
For lngLoop = LBound(arrNames) To UBound(arrNames)
strName = arrNames(lngLoop, 1)
wksMaster.Copy
Set wksOutput = ActiveSheet
With wksOutput
.Name = strName
'Delete Non-Matching Names
Call SortFilterDelete(wksOutput, "C", "Keep", strName)
lngLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
'Get List Of Unique Values
.Range("Q1").Formula2R1C1 = _
"=SORT(UNIQUE(R2C4:R" & lngLastRow & "C4))"
lngLastRow = .Cells(.Rows.Count, "Q").End(xlUp).Row
Set rngCells = .Range("Q1:Q" & lngLastRow)
rngCells = rngCells.Value
arrSheets = .Range("Q1:Q" & lngLastRow).Value
rngCells.ClearContents
lngLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
'Single Records Skip Sort/Filter/Deletion
If lngLastRow = 2 Then
strLevel = .Range("D2")
.Name = strLevel
GoTo ThaDanceFloor
Else
For lngLoop2 = 2 To lngLastRow
strLevel = .Range("D" & lngLoop2)
.Copy After:=wksOutput
Set wksCopy = ActiveSheet
With wksCopy
.Name = strLevel
Call SortFilterDelete _
(wksCopy, "D", "Keep", strLevel)
End With
Next lngLoop2
.Visible = xlSheetHidden
End If
ThaDanceFloor:
.Parent.SaveAs Filename:=strName
End With
Next lngLoop
End With
Application.ScreenUpdating = True
End Sub
