I get an error in the following block (Red Font) when I run the code. Also, I can't see where the code is opening a new workbook to copy the worksheets too.

ReDim Preserve SheetsCopy(UBound(SheetsCopy) - 1)
    Sheets(SheetsCopy).Copy
    'loop through and name the new worksheets based on the value in the holding cell
    For Each ws In ActiveWorkbook.Worksheets
        ws.Name = ws.Cells(1, 4).Value
        ws.Range("D1").Clear
    Next