Option Explicit
Sub Split_Trust_Wise_Data()
Dim MySheet As Worksheet, ws As Worksheet
Dim i As Long, N As Workbook
Dim UList As Collection, UListValue As Variant, c As Integer
Dim response As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
response = MsgBox("Are you ready because files with same name would get replaced.", vbQuestion + vbYesNo)
If response = vbNo Then Exit Sub
c = 5
Set MySheet = ActiveSheet
Set UList = New Collection
For Each ws In ThisWorkbook.Sheets
With ws
On Error Resume Next
For i = 2 To .Range("A1").CurrentRegion.Rows.Count
If Len(.Cells(i, c)) > 0 Then UList.Add .Cells(i, c), CStr(.Cells(i, c))
Next i
On Error GoTo 0
End With
Next
For Each UListValue In UList
Set N = Workbooks.Add(xlWBATWorksheet)
For Each ws In ThisWorkbook.Sheets
With ws
.[S2].Value = UListValue
If Len(.[S3]) > 0 Then .[S3].Value = UListValue
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy _
, .Range("S1:T2"), .Range("W1:AI1"), Unique:=False
End With
With N
ws.Range("W1").CurrentRegion.Copy
Sheets.Add().Name = ws.Name
Sheets(ws.Name).Paste
Cells.EntireColumn.AutoFit
End With
Next ws
For Each ws In N.Worksheets
If IsEmpty(ws.[A1]) Then ws.Delete
Next
N.SaveAs Filename:=Application.ThisWorkbook.Path & "\" & UListValue.Value
N.Close False
Set ws = Nothing
Next UListValue
MySheet.Select
MsgBox "DONE-DONE-DONE", vbInformation
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
