What I personally did was
Create a separate helper column with - =FLOOR(ROW()/6000,1)
Searched for a code to sort the range based on a column. Came across this code
Function RemoveDuplicates(cities As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "Path"
Sheets("cities").Activate
On Error GoTo 0
cities.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "Cities"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub creatfiles(cities As Range, clmNo As Long)
Dim wb As Workbook 'for gh files
Dim foldPath As String 'folder path for saving files
Application.FileDialog(msoFileDialogFolderPicker).Show
foldPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
ThisWorkbook.Activate
For Each cell In cities
Sheet1.Activate
Dim lstClm As Long
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=cell.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Set wb = Workbooks.Add
ActiveCell.PasteSpecial xlPasteAll
wb.SaveAs foldPath & "/" & cell.Value
wb.Close
Dim fullFileName As Range
Set fullFileName = ThisWorkbook.Sheets("cities").Range(cell.Address).Offset(0, 1)
Debug.Print cell.Address
fullFileName.Value = foldPath & "/" & cell.Value & ".xlsx"
Debug.Print fullFileName.Address
ThisWorkbook.Activate
Debug.Print foldPath & "/" & cell.Value
Next cell
End Sub
Sub Spliter()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AlertBeforeOverwriting = False
.Calculation = xlCalculationManual
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filer if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim cities As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set cities = Range(clm & "2:" & clm & lstRow)
Set cities = RemoveDuplicates(cities)
Call creatfiles(cities, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Data.ShowAllData
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
