Option Explicit
'1. You have a sheet1 in workbook1 that has loads of entries in Column A.
'2. A folder is created in My Docs, named Route Backups & current date
'3. The macro runs from A1 down, and when the value changes, say in A40, it:
'4. copies rows 1:39 from sheet1 into sheet in a temporary workbook.
'5. This sheet gets named after the value in its A1.
'6. This sheet is exported as .csv in this folder
'7. Then the macro continues on sheet1. When the value changes again, say row 85, it
'exports this section as per 4-6 above.
Sub SetupCSV()
Dim wsSrc As Worksheet, wsOut As Worksheet
Dim wbCSV As Workbook
Dim lRsrc As Long, lRLast As Long, lC As Long
Dim vOut As Variant, vIn As Variant
Dim sFolderName As String, sTab As String, sRootPath As String
Set wsSrc = Sheets("Sheet1") '<<<< Modify as required. This is the sheet with all the entries to be sorted
sRootPath = "R:\Temp" '<<<< Modify as required. Note: _
This root directory where the backup subdirectories will be stored must exist
'make the name of the subdirectory for today
sFolderName = "\Route Backups " & Format(Date, "yyyy-mm-dd")
'create the directory if not exists
If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
MkDir sRootPath & sFolderName
'check if created OK
If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
MsgBox prompt:="Someting went wrong trying to create the " & vbCrLf & _
"subdirectory " & sFolderName & _
" in the root directory " & sRootPath & ". " & vbCrLf & _
"Please check if rootpath exists. Then retry.", _
Buttons:=vbCritical + vbOKOnly, _
Title:="Error creating sub directory"
Exit Sub
End If
End If
Application.ScreenUpdating = False
Set wbCSV = Workbooks.Add
Set wsOut = wbCSV.Sheets(1)
'load column A in array for fast reading
lRsrc = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row + 1
vIn = wsSrc.Range("A1").Resize(lRsrc, 1)
lC = wsSrc.Range("A1").CurrentRegion.Columns.Count
lRLast = 1
For lRsrc = 2 To lRsrc
If vIn(lRsrc, 1) <> vIn(lRsrc - 1, 1) Then
'change detected. Read the section above into array
vOut = wsSrc.Cells(lRLast, 1).Resize(lRsrc - lRLast, lC).Value
lRLast = lRsrc
'clear sheet and copy
wsOut.Range("A1").CurrentRegion.Clear
wsOut.Range("A1").Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut
wsOut.Name = ReplaceIllegalCharacters(wsOut.Range("A1"), "_")
'create csv
wsOut.SaveAs Filename:=sRootPath & sFolderName & "\" & wsOut.Name & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=False
End If
Next lRsrc
'close and clean up
Workbooks(wsOut.Name & ".csv").Close savechanges:=False
Set wsSrc = Nothing
Set wsOut = Nothing
Application.ScreenUpdating = True
End Sub
Function ReplaceIllegalCharacters(strIn As String, strChar As String) As String
'courtesy: jainashish
Dim strSpecialChars As String
Dim i As Long
strSpecialChars = "~""#%&*:<>?{|}/\[]" & Chr(10) & Chr(13)
For i = 1 To Len(strSpecialChars)
strIn = Replace(strIn, Mid$(strSpecialChars, i, 1), strChar)
Next
ReplaceIllegalCharacters = strIn
End Function