Export2CSV

Exports a sheet into CSV file
Dynamically finds number of rows/columns and export as they are, starting from A1.
Forcing each column to be exported as the format found in its row 2, meaning, if a cell has 0.35444 and displayed as 35%, it will be forced to ba saved as 35% in CSV.
Can pass sheet, workbook and file names as parameters as well as SaveMethod.

CodeFunctionName
What is this?

Public

Tested

Original Work
Function Export2CSV(CSVFullFileName, Optional Shee = "Active", Optional Wb = "This", Optional StartCell = "A1", Optional SaveOver = 1, Optional SaveMethod = 1)
    ' exports a sheet into CSV file
    ' Dynamically finds number of rows/columns and export as they are, starting from A1
    '    Forcing each column to be exported as the format found in its row 2, meaning, if a cell has 0.35444 and displayed as 35%, it will be forced to ba saved as 35% in CSV
    '    Replaces CSV if already found and if SaveOver = 1
    '    Decide method of saving in SaveMode variable,
    '
    If Wb = "This" Then Wb = ThisWorkbook.Name
    If Wb = "Active" Then Wb = ActiveWorkbook.Name
    If Shee = "Active" Then Shee = ActiveSheet.Name
   
    FormatExclude1 = "General"
    If IsThere1(CSVFullFileName, True, True) Then
        If SaveOver = 1 Then
            Kill CSVFullFileName
            DoEvents
        Else
            Exit Function
        End If
    End If
    Rowsco = Workbooks(Wb).Worksheets(Shee).Range(StartCell).CurrentRegion.Rows.Count
    ColsCo = Workbooks(Wb).Worksheets(Shee).Range(StartCell).CurrentRegion.Columns.Count
    FileContent = ""
    For I = 1 To Rowsco
        Line1 = ""
        For J = 1 To ColsCo
            If Line1 > "" Then Line1 = Line1 & ","
            Err.Clear
            On Error Resume Next
            CellContent = Workbooks(Wb).Worksheets(Shee).Range(StartCell).Offset(I - 1, J - 1).Value2
            CellFormat = Workbooks(Wb).Worksheets(Shee).Range(StartCell).Offset(1, J - 1).NumberFormat
            CellVal = CellContent
            If UCase(CellFormat) = UCase(FormatExclude1) Then
            Else
                CellFormat = Replace(CellFormat, "_)", "")
                CellFormat = Replace(CellFormat, "_(", "")
                CellVal = Format(CellContent, CellFormat)
            End If
            If InStr(1, CellVal, ",") > 0 Then CellVal = Chr(34) & CellVal & Chr(34)
            Line1 = Line1 & CellVal
            If Err.Number < > 0 Then Line1 = Line1 & ""
            DoEvents
        Next
        FileContent = FileContent & Line1 & vbCrLf
        DoEvents
    Next
    If SaveMethod = 1 Then ' ADODB
        Dim fsT
        Set fsT = CreateObject("ADODB.Stream")
        fsT.Type = 2                ' Specify stream type - we want To save text/string data.
        fsT.Charset = "utf-8"            ' Specify charset For the source text data.
        fsT.Open ' Open the stream And write binary data To the object
        fsT.WriteText FileContent
        fsT.SaveToFile server.MapPath(CSVFullFileName), 2    'Save binary data To disk
        Set fsT = Nothing
    ElseIf SaveMethod = 2 Then
        Set fso = CreateObject("scripting.FileSystemObject")        ' for VBA
        Set myFile = fso.CreateTextFile(CSVFullFileName, True)
        myFile.WriteLine (FileContent)
        myFile.Close
    ElseIf SaveMethod = 3 Then
        Close
        Open CSVFullFileName For Output As #3
        Print #3, FileContent
        Close
    End If
End Function

CSVFullFileName, Optional Shee = "Active", Optional Wb = "This", Optional StartCell = "A1", Optional SaveOver = 1, Optional SaveMethod = 1

Views 182

Downloads 63

CodeID
DB ID

ANmarAmdeen
626
Attachments
Revisions

v1.0

Monday
May
16
2022