La macro no copia la validación de datos en las celdas

Question

Tengo una macro para copiar una selección de una hoja y enviarla por correo electrónico como un archivo adjunto separado, sin embargo, no copia la validación de datos que existe en esas celdas.

En la hoja hay validación que existe en las columnas AT, AU, AV, AW y AY. Cuando ejecuto el código siguiente, no copia la validación en la hoja que se envía por correo electrónico. Necesito que el archivo adjunto tenga la misma validación en esas columnas que la hoja original y el mismo formato.

Sub send_email()
Dim Data, Dict As Object, Id As String, File As String, i As Long
Set Dict = CreateObject("scripting.dictionary")
With Cells(1).CurrentRegion
    Data = .Value
    For i = 2 To UBound(Data)
        If Not Dict.exists(Data(i, 59)) Then
            Id = Data(i, 58)
            File = ThisWorkbook.Path & "\" & Id & " - PCP" & ".xlsx"
            Dict.Add Data(i, 59), 1
            .AutoFilter 59, Data(i, 59)
            .SpecialCells(12).Copy Sheets.Add.Cells(1)
            With ActiveSheet
                .Copy
                With ActiveWorkbook
                    .ActiveSheet.Name = "Sheet1"
                    .SaveAs File
                    .Close
                End With
                Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
            End With
            With CreateObject("Outlook.Application").CreateItem(0)
                .display
                .To = Data(i, 59)
                .Subject = "Work Assignment for Today"
                .HTMLBody = "Good Morning " & "<br><br>" & "Please find attached your work assignment for the day" & .HTMLBody
                .Attachments.Add File
                .display '! Change to Send after testing
            End With
            Kill File
            .AutoFilter
        End If
    Next i
End With
End Sub

Answer 1

Pude resolver esto usando el siguiente código.

ActiveWorkbook.Worksheets(Array(.Name, "Disp")).Copy