Option Explicit
Sub StripProteins()
Process_Sheets Protein_List(Sheet_List)
Macro_Finish
End Sub
Private Function LastCell(ByRef w As Worksheet, Optional ByRef d As Boolean = False) As Long
With w.Cells
LastCell = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
If d Then LastCell = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False).Column
End With
End Function
Private Function Sheet_List() As Worksheet
On Error Resume Next
Set Sheet_List = Sheets("List")
On Error GoTo 0
If Sheet_List Is Nothing Then
MsgBox "Sheet List not found!", vbExclamation, "List Sheet Not Found"
Else
Application.ScreenUpdating = False
Sheet_List.Move before:=Sheets(1)
Application.ScreenUpdating = True
End If
End Function
Private Function Protein_List(ByRef w As Worksheet) As Object
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
Dim v As Variant
Dim x As Long
With w
v = .Range("A2:A" & LastCell(w)).Value
End With
For x = LBound(v, 1) To UBound(v, 1)
d(v(x, 1)) = x
Next x
Set Protein_List = d
End Function
Private Sub Process_Sheets(ByRef v As Object)
Dim w As Long
Application.ScreenUpdating = False
For w = 2 To Worksheets.Count
Test_Sheet Sheets(w), v, LastCell(w), LastCell(w, True)
Next w
Application.ScreenUpdating = True
End Sub
Private Sub Test_Sheet(ByRef w As Worksheet, v As Object, ByRef LR As Long, ByRef LC As Long)
Dim key As Variant
Dim r As Range
On Error Resume Next
With w
LR = LastCell(w)
LC = LastCell(w, True)
Set r = .Range("B22:B" & LR)
r.Select
For Each key In v
r.Replace key, ""
Next key
End With
With r
.SpecialCells(xlCellTypeBlanks).EntireRow.Value = vbNullString
.Resize(, LC).Sort key1:=r.Cells(1, 1), order1:=xlAscending
End With
On Error GoTo 0
End Sub
Private Sub Macro_Finish()
Sheets(1).Activate
MsgBox "Finished clearing proteins out", vbOKOnly, "No Keto Diet Here"
End Sub