Untitled

reading and writing a csv file using FileSystemObject

Set objFSO = CreateObject("scripting.filesystemobject")

    'create a csv file

    Set objTF = objFSO.createtextfile("C:testmyfile.csv", True, False)

    'open an existing csv file with writing ability

    Set objTF = objFSO.OpenTextFile("C:testmyfile.csv", 8)

       

Const sFilePath = "C:testmyfile.csv"

Const strDelim = ","

Sub CreateCSV_FSO()

    Dim objFSO

    Dim objTF

    Dim ws As Worksheet

    Dim lRow As Long

    Dim lCol As Long

    Dim strTmp As String

    Dim lFnum As Long

 

    Set objFSO = CreateObject("scripting.filesystemobject")

    Set objTF = objFSO.createtextfile(sFilePath, True, False)

 

    For Each ws In ActiveWorkbook.Worksheets

        'test that sheet has been used

        Set rng1 = ws.UsedRange

        If Not rng1 Is Nothing Then

            'only multi-cell ranges can be written to a 2D array

            If rng1.Cells.Count > 1 Then

                X = ws.UsedRange.Value2

                'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column

                For lCol = 1 To UBound(X, 2)

                    'write initial value outside the loop

                    strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))

                    For lRow = 2 To UBound(X, 1)

                        'concatenate long string & (short string with short string)

                        strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))

                    Next lRow

                    'write each line to CSV

                    objTF.writeline strTmp

                Next lCol

            Else

                objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)

            End If

        End If

    Next ws

 

    objTF.Close

    Set objFSO = Nothing

    MsgBox "Done!", vbOKOnly

 

End Sub