Look this:
Sub Macro1()
XLSFile = "C:\Pasta1_X.xls" 'File to export
NewFile = "C:\teste.cvs"
Dim objWbk As Workbook
Set objWbk = Workbooks.Open(XLSFile)
objWbk.Activate
objWbk.SaveAs _
Filename:=NewFile, _
FileFormat:=xlCSV, _
CreateBackup:=False
objWbk.Close
Set objWbk = Nothing
Call DivideArquivo(NewFile)
MsgBox ("End")
End Sub
Private Function DivideArquivo(ByVal strFile As String)
Dim Fso As Object 'New FileSystemObject
Dim Arquivo As Object 'TextStream
Dim NewArquivo As Object 'TextStream
Dim strFileName As String
Dim strNewFileName As String
Dim strExtensao As String
Dim IntFile As Integer
Dim strLine As String
Dim strNewFolder As String
Set Fso = CreateObject("Scripting.FileSystemObject")
'Separate the file in same folder of original file
' eg.: TesteFile.txt = will be on folder:
TesteFile-Separados\TesteFile-00n.txt
strFileName = Trim(strFile)
strNewFolder = Left(strFileName, InStrRev(strFileName, "\")) & strNewFolder
strFileName = Right(strFileName, Len(strFileName) - InStrRev(strFileName,
"\"))
strNewFolder = strNewFolder & Left(strFileName, Len(strFileName) - 4) &
"-Separados\"
strExtensao = Right(strFileName, 3)
strFileName = Left(strFileName, Len(strFileName) - 4)
If Not Fso.FolderExists(strNewFolder) Then Fso.CreateFolder (strNewFolder)
strNewFileName = strNewFolder & strFileName & "-" & Right("00" & IntFile, 3)
& "." & strExtensao
Set Arquivo = Fs
penTextFile(strFile, 1) 'ForReading)
Call Fso.CreateTextFile(strNewFileName)
Set NewArquivo = Fs
penTextFile(strNewFileName, 8) 'ForAppending
IntFile = 0
While Not Arquivo.AtEndOfStream
CountLine = CountLine + 1
If CountLine > 300 Then 'separate the file in 300 lines
CountLine = 0
'If FileLen(strNewFileName) >= txtFileLen * 1024 Then ' if you want to
separate the file in Mb
IntFile = IntFile + 1
strNewFileName = strNewFolder & strFileName & "-" & Right("00" &
IntFile, 3) & "." & strExtensao
NewArquivo.Close
Set NewArquivo = Nothing
Call Fso.CreateTextFile(strNewFileName)
Set NewArquivo = Fs
penTextFile(strNewFileName, 8) 'ForAppending)
End If
DoEvents
strLine = Arquivo.ReadLine
Call NewArquivo.WriteLine(strLine)
strLine = Empty
NewArquivo.Close
Set NewArquivo = Fs
penTextFile(strNewFileName, 8) 'ForAppending)
Wend
NewArquivo.Close
Set NewArquivo = Nothing
Arquivo.Close
Set Arquivo = Nothing
End Function
Public Function fFsoCriaArquivo(ByVal pstrNmArquivo As String, _
Optional ByVal pblnSubstituiArq As Boolean, _
Optional ByVal pblnAskSubtituiArq As Boolean)
Dim Fso As FileSystemObject
Dim Resp As String
Set Fso = New FileSystemObject
If Fso.FileExists(pstrNmArquivo) Then
If pblnAskSubtituiArq And Not pblnSubstituiArq Then
Resp = MsgBox("File already exists!" & vbCrLf & "Do you want to
substitute?", vbYesNo, "File exists")
If Resp = vbYes Then
pblnSubstituiArq = True
Else
Set Fso = Nothing
Exit Function
End If
End If
If pblnSubstituiArq Then
Call Fso.DeleteFile(pstrNmArquivo)
End If
End If
If Not pblnSubstituiArq And Not pblnAskSubtituiArq Then
Set Fso = Nothing
Exit Function
End If
Call Fso.CreateTextFile(pstrNmArquivo)
Set Fso = Nothing
MsgBox "Fim", vbInformation, ""
End Function
