Sub split_dat2()
'split data by sorting
Application.ScreenUpdating = False
Dim cRange As Range, sortCol As Range, firstRow As Range
Set cRange = ActiveCell.CurrentRegion
Set sortCol = cRange.Columns(5)
Set sortCol = Range(sortCol.Cells(2), sortCol.Cells(sortCol.Cells.Count() - 1))
Set firstRow = cRange.Rows(1)
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=sortCol _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("sheet1").Sort
.SetRange cRange
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim NewWorkbook As Workbook
Dim ThisWorkbook As Workbook
Dim NewWorkbookName As String
Dim relativePath As String
Dim c As Range, prevC As String, rowNum As Long, i As Long
Dim lastrow As Integer
Set ThisWorkbook = ActiveWorkbook
prevC = ""
rowNum = 2
For Each c In sortCol
If c.Value <> prevC Then
If Not NewWorkbook Is Nothing Then
NewWorkbook.Close savechanges:=True
End If
'we have a new item, time to create a file
NewWorkbookName = c.Value & ".xlsx"
Set NewWorkbook = Workbooks.Add
relativePath = ThisWorkbook.Path & "\split\" & NewWorkbookName
ActiveWorkbook.SaveAs Filename:=relativePath
firstRow.Copy Workbooks(NewWorkbookName).Sheets(1).Cells(1, 1)
i = 2
prevC = c.Value
End If
cRange.Rows(rowNum).Copy Workbooks(NewWorkbookName).Sheets(1).Cells(i, 1)
i = i + 1
rowNum = rowNum + 1
Next c
NewWorkbook.Close savechanges:=True
Application.ScreenUpdating = True
End Sub
