Option Explicit
Public Sub SplitByCode()
Dim DataSheet As Worksheet
Dim CodeSheet As Worksheet
Dim NewSheet As Worksheet
Dim DataRange As Range
Dim SortRange As Range
Dim OriginalRange As Range
Dim CriteriaRange As Range
Dim FoundRange As Range
Dim CopyRange As Range
Dim DataLastRow As Long
Dim CodeLastRow As Long
Dim Index As Long
Const CodeSheetName As String = "Codes"
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error GoTo Tidyup
Set DataSheet = ThisWorkbook.Worksheets("Sheet1")
DeleteSheet CodeSheetName, ThisWorkbook
Set CodeSheet = ThisWorkbook.Worksheets.Add
CodeSheet.Name = CodeSheetName
DataSheet.Columns("C:C").Copy CodeSheet.Range("A1")
CodeSheet.Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
DataLastRow = DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Row
CodeLastRow = CodeSheet.Cells(CodeSheet.Rows.Count, 1).End(xlUp).Row
Set DataRange = DataSheet.Range("A1:O" & DataLastRow)
Set OriginalRange = DataSheet.Range("P2:P" & DataLastRow)
Set CriteriaRange = DataSheet.Range("Q2:Q" & DataLastRow)
Set SortRange = DataRange.Cells(1, 1).Resize(DataRange.Rows.Count, DataRange.Columns.Count + 2)
OriginalRange.Cells(1, 1).Offset(-1, 0).Resize(1, 2).Value = Array("Original", "Criteria")
OriginalRange.Formula = "=ROW(A1)"
OriginalRange.Value = OriginalRange.Value
For Index = 2 To CodeLastRow
CriteriaRange.Formula = "=1/(C2=" & Chr(34) & CodeSheet.Cells(Index, 1).Value & Chr(34) & ")"
CriteriaRange.Value = CriteriaRange.Value
SortRange.Sort Key1:=CriteriaRange.Cells(1, 1).Offset(-1, 0), Order1:=xlAscending, Header:=xlYes
On Error Resume Next
Set FoundRange = CriteriaRange.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not FoundRange Is Nothing Then
Set CopyRange = Intersect(DataRange, FoundRange.EntireRow)
Set NewSheet = ThisWorkbook.Worksheets.Add
DeleteSheet "Code " & CodeSheet.Cells(Index, 1).Value, ThisWorkbook
NewSheet.Name = "Code " & CodeSheet.Cells(Index, 1).Value
NewSheet.Cells(1, 1).Resize(1, DataRange.Columns.Count).Value = DataRange.Cells(1, 1).Resize(1, DataRange.Columns.Count).Value
NewSheet.Cells(2, 1).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count).Value = CopyRange.Value
SaveSheet NewSheet
Set CopyRange = Nothing
Set FoundRange = Nothing
End If
Next Index
Tidyup:
SortRange.Sort Key1:=OriginalRange.Cells(1, 1).Offset(-1, 0), Order1:=xlAscending, Header:=xlYes
OriginalRange.Cells(1, 1).Offset(-1, 0).Resize(OriginalRange.Rows.Count + 1, 2).ClearContents
DeleteSheet "Codes", ThisWorkbook
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub DeleteSheet(ByVal SheetName As String, ByVal Book As Workbook)
Dim AppDisplayAlerts As Boolean
AppDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
On Error Resume Next
Book.Worksheets(SheetName).Delete
On Error GoTo 0
Application.DisplayAlerts = AppDisplayAlerts
End Sub
Private Sub SaveSheet(ByVal SourceSheet As Worksheet)
Dim SourceBook As Workbook
Dim TargetBook As Workbook
Set SourceBook = SourceSheet.Parent
Set TargetBook = Workbooks.Add(xlWBATWorksheet)
SourceSheet.Move After:=TargetBook.Worksheets(1)
TargetBook.Worksheets(1).Delete
TargetBook.SaveAs Filename:=SourceBook.Path & Application.PathSeparator & "Area Sample - " & TargetBook.Worksheets(1).Name, FileFormat:=xlOpenXMLWorkbook
TargetBook.Close False
End Sub