copy recordset to CSV file

[macroapa]

Hi, I have the following code below which happily breaks down a CSV
into different worksheets in excel. However, what I want the VBA code
to do is copy the recordset to new CSV files, my code already creates
the new CSV files, but how do I send the data to the csv file and not
the worksheet? Thanks

Code:

Option Explicit

Sub ImportLargeFile()
Dim strFilePath As String, strFilename As String, strFullPath As
String
Dim oFile As TextStream
Dim lngCounter As Long
Dim oConn As Object, oRS As Object, oFSObj As Object
Dim xFile As Integer
Dim xFileName As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim xStr As String
xFile = 1
xFileName = "C:\Users\Steve\Desktop\New folder\output"
'Get a text file name
strFullPath = "C:\Users\Steve\Desktop\New folder\test.csv"



'This gives us a full path name e.g. C:tempfolderfile.txt
'We need to split this into path and file name
Set oFSObj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")

strFilePath = oFSObj.GetFile(strFullPath).ParentFolder.Path
strFilename = oFSObj.GetFile(strFullPath).Name
Debug.Print (strFilePath)
Debug.Print (strFilename)

'Open an ADO connection to the folder specified
Set oConn = CreateObject("ADODB.CONNECTION")
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strFilePath & ";" & _
"Extended Properties=""text;HDR=Yes;FMT=Delimited"""

Set oRS = CreateObject("ADODB.RECORDSET")

'Now actually open the text file and import into Excel
oRS.Open "SELECT * FROM " & strFilename, oConn, 3, 1, 1
While Not oRS.EOF
xFileName = "C:\Users\Steve\Desktop\New folder\output" & xFile
& ".csv"
Set oFile = fso.CreateTextFile(xFileName, True)
Worksheets(xFile).Range("A1").CopyFromRecordset oRS, 10000
xFile = xFile + 1
Wend

oRS.Close
oConn.Close

Application.ScreenUpdating = True


End Sub

 

[GS]

Here's a reusable procedure you can use to send each record to a file
as requested.

Sub WriteTextFileContents(Text As String, FileName As String, Optional
AppendMode As Boolean = False)
' A reuseable procedure to write or append large amounts of data to a
text file

Dim iNum As Integer, bIsOpen As Boolean

On Error GoTo ErrHandler
iNum = FreeFile()
If AppendMode Then Open FileName For Append As #iNum Else Open
FileName For Output As #iNum
'If we got here the file has opened successfully
bIsOpen = True

'Print to the file in one single step
Print #iNum, Text


ErrHandler:
'Close the file
If bIsOpen Then Close #iNum
If Err Then Err.Raise Err.Number, , Err.Description
End Sub 'WriteTextFileContents()

Watch for word wraps of single lines.

This is a very fast, self-contained procedure so you don't have to
include its code in other procs. Example:

<air code>
In your current proc:
Const sPath As String = "C:\Users\Steve\Desktop\New folder\output"
While Not oRS.EOF
xFilename = sPath & xFile & ".csv"
WriteTextFileContents oRS, xFilename
xFile = xFile + 1
Wend

If you want to parse the recordset into subsets first, do that and pass
the entire subset for the first arg. So, for example, to parse the
recordset into subsets of 10,000 you'd have to dump the data into an
array or string var delimited by vbCrLf. I think it would be faster to
load the data into a string var<IMO>.

<air code>
Dim i As Integer, sSubSet As String
Const sPath As String = "C:\Users\Steve\Desktop\New folder\output"
Const iMaxRows As Integer = 10000
While Not oRS.EOF
xFilename = sPath & xFile & ".csv"
For i = 1 To iMaxRows
sSubSet = sSubSet & oRS & vbCrLf: oRS.MoveNext
Next
WriteTextFileContents sSubSet, xFilename
xFile = xFile + 1
Wend

HTH