Sub SplitSystemNewSheet()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim i As Long
Dim Message1, Message2, Message3, Title, Default1, Default2, _
Default3, MyVal1, MyVal2, MyVal3
'turn off screen updating
Application.ScreenUpdating = False
'select the first worksheet with the data
Set wsAll = Worksheets(1)
'check if data exists, if not exit sub
If wsAll.Cells(2, 1).Value = "" Then
MsgBox "No data exists press OK to exit", vbInformation, "No data!"
Exit Sub
End If
'find the last row of data
LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
'show the form
Load UserForm1
UserForm1.Show
'assign values from userform
MyVal1 = UserForm1.TextBox1.Value
MyVal2 = UserForm1.TextBox2.Value
MyVal3 = UserForm1.TextBox3.Value
'use col z for the formula to extract the required characters
With wsAll.Range("Z1")
.Value = "ID"
.Offset(1).Resize(LastRow - 1).Value = "=MID(" & MyVal1 & "2," & MyVal2 & "," & MyVal3 & ")"
End With
'add sheet for the criteria
Set wsCrit = Worksheets.Add
'column y has the criteria eg ID
wsAll.Range("Z1:Z" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRowCrit
'add new sheet for each system
Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wsNew.Name = wsCrit.Range("A2")
wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
wsNew.Cells.WrapText = False
wsNew.Cells.EntireColumn.AutoFit
wsNew.Range("A1").AutoFilter
wsCrit.Rows(2).Delete
wsNew.Range("Z:Z").Clear
'freeze panes
wsNew.Range("A2").Select
ActiveWindow.FreezePanes = True
Next i
'disable confirm sheet delete dialogue and delete sheets
Application.DisplayAlerts = False
wsCrit.Delete
wsAll.Delete
Application.DisplayAlerts = True
'turn on screen updating
Application.ScreenUpdating = True
'close the userform
Unload UserForm1
'clear memory
Set wsCrit = Nothing
End Sub