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.
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
' 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 115
Downloads 40
CodeID
DB ID