Sub Разбить_по_файлам_ИЗМ()    
Dim oDic As Object, oFSO As Object    
Dim arrData(), arrSeparateItems()    
Dim TempWb As Workbook    
Dim sFolderPath As String, sFullFileName As String    
Dim LastRow As Long, i As Long, n As Long    
Dim RngData As Range, FilteredRng As Range        
If MsgBox("Разбить по файлам?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub        
sFolderPath = ThisWorkbook.Path & "\" 'здесь укажите путь для сохранения файлов      
Application.ScreenUpdating = False       
Set oFSO = CreateObject("Scripting.FileSystemObject")    
Set oDic = CreateObject("Scripting.Dictionary")       
Dim shSource As Worksheet    
Set shSource = ActiveSheet       
Dim Application_Calculation As XlCalculation    
Application_Calculation = Application.Calculation   
Application.Calculation = xlCalculationManual       
With shSource              
If .FilterMode = True Then .ShowAllData        
LastRow = .Cells(.Rows.Count, 12).End(xlUp).Row        
arrData = .Range("T1:T" & LastRow).Value 'столбец, где нужно найти уникальные значения        
Set RngData = .Range("A1").CurrentRegion    
End With       
For i = 21 To UBound(arrData)        
If Not oDic.Exists(arrData(i, 1)) Then oDic.Add arrData(i, 1), 0&    
Next i       
arrSeparateItems() = oDic.Keys       
For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)        
shSource.Copy

 



ХОТЕЛОСЬ БЫ СЮДА СКОПИРОВАТЬ ЕЩЕ ЛИСТ "Новый лист", КОТОРЫЙ СОДЕРЖИТСЯ В ИСХОДНОЙ КНИГЕ      






Set TempWb = ActiveWorkbook 
...ОПРЕДЕЛЕННЫЕ ДЕЙСТВИЯ С ЛИСТОМ, СКОПИРОВАННЫМ В ТЕКУЩУЮ КНИГУ... 
ActiveSheet.name = arrSeparateItems(n)         
sFullFileName = sFolderPath & arrSeparateItems(n) & ".xlsx"        
If oFSO.FileExists(sFullFileName) Then oFSO.Deletefile (sFullFileName)        
TempWb.SaveAs sFullFileName, FileFormat:=xlOpenXMLWorkbook 'XLSX        
TempWb.Close SaveChanges:=False    
Next n       
With ActiveSheet        
If .FilterMode = True Then .ShowAllData    
End With      
Application.Calculation = Application_Calculation    
Application.ScreenUpdating = True    
MsgBox "Файлы сохранены в " & sFolderPath, vbInformation, "Конец"
End Sub

Sheets(Array(Новый лист", ТЕКУЩИЙ ЛИСТ ЗАДАННЫЙ СЕЙЧАС КАК ShSourse)).Copy