VBA Stops Running When it Reaches a Blank Cell

Hello Everyone,

I have an Excel spreadsheet that I am preparing for use. In the spreadsheet, i have a VBA macro set up to transfer out data from the main sheet into separate sheets based on whether the answers in column J is "yes" or "no".

The macro is working well, except it stops running if there is a blank cell in the column. For example, if i have data listed from rows 2 through 10, but if an answer was not submitted in J6, the macro will only transfer out rows 2-5 into new sheets.

How can i get the macro to continue past the blank cell if there is one? Below is the VBA i have now.


Sub CopyByCriteriaMet()
Dim FilterRng As Range
Dim TargetSh As Worksheet
Dim Criteria As Variant
Dim DestSh As Worksheet

Application.ScreenUpdating = False
Set TargetSh = Worksheets("Sheet1")
Set FilterRng = Range("J1", Range("J1").End(xlDown))

FilterRng.AdvancedFilter xlFilterCopy, copytorange:=TargetSh.Range("P1"), unique:=True
Criteria = TargetSh.Range("P2", TargetSh.Range("P1").End(xlDown))
Columns("P").ClearContents

For m = LBound(Criteria, 1) To UBound(Criteria, 1)
Set DestSh = Worksheets.Add(after:=Sheets(Sheets.Count))
DestSh.Name = Criteria(m, 1)
FilterRng.AutoFilter field:=1, Criteria1:=Criteria(m, 1)
FilterRng.SpecialCells(xlCellTypeVisible).EntireRow.Copy DestSh.Range("A1")
Next
FilterRng.AutoFilter
TargetSh.Activate
Application.ScreenUpdating = True
End Sub


Thank you in advance for any help and advise!! :)