From XLS into CSV - macro Save As visual option - excel

Question

I am glad to be here with great programmers and hope I will learn a lot. I am also new in this kind of programming so I am sorry for any inconvenience.
I am using the vba code below to transfer my files from XLS into CSV. After it translates the xls file into csv format, it saves automatically my newly created csv file in the same directory as my original xls file.
I would like to have a Save As option for my csv filename
Thank you in advance.
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Integer
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Probably the problem is here. This part of code has to be re-writen or corrected.
This is the main function which calls other ones.
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Integer
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub

Answer 1

This updated code gives you a SaveAs name option (with a default as WorkbookName.csv)
More efficient code using variant arrays to make your csv below.
These are the three key updated lines:
strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv")
If strFileName = "False" Then Exit Sub
Open strFileName For Output As #nFileNum
updated code
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Dim strFileName As String
Sep = ";"
csvPath = Application.ActiveWorkbook.path
Dim brojac As Long
brojac = 0
For Each wsSheet In Worksheets
If brojac > 0 Then Exit For
wsSheet.Activate
nFileNum = FreeFile
strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv")
If strFileName = "False" Then Exit Sub
Open strFileName For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
brojac = brojac + 1
Next wsSheet
End Sub
more efficient csv code
From Creating and Writing to a CSV File Using Excel VBA
This code must be run from a regular VBA Code Module. Otherwise the code will cause an error if users try to run it from the ThisWorkbook or Sheet Code panes given the usage of Const.
It is worth noting that the ThisWorkbook and Sheet code sections should be reserved for Event coding only, "normal" VBA should be run from standard Code Modules.
Please note that for purposes of the sample code, the file path of the CSV output file is "hard-coded" as: C:\test\myfile.csv at the top of the code. You will probably want to set the output file programmatically, for instance as a function parameter.
As mentioned earlier; For example purposes, this code TRANSPOSES COLUMNS AND ROWS; that is, the output file contains one CSV row for each column in the selected range. Normally, CSV output would be row-by-row, echoing the layout visible on screen, but I wanted to demonstrate that generating the output by using VBA code provides options beyond what is available by, for instance, using the Save As... CSV Text menu option.
code
Const sFilePath = "C:\test\myfile.csv"
Const strDelim = ","
Sub CreateCSV_Output()
Dim ws As Worksheet
Dim rng1 As Range
Dim X
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
lFnum = FreeFile
Open sFilePath For Output As lFnum
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
Print #lFnum, strTmp
Next lCol
Else
Print #lFnum, IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
Close lFnum
MsgBox "Done!", vbOKOnly
End Sub
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