none
VBA code to transform XLS into CSV files

    Question

  • This is code for translating files from XLS into CSV that I am using.

    I need to do some modifications but I don't know how to do that.

    I need when I start this macro, that he opens me dialog box, save as, like in excel mode File->Save As that I coose where to save that file.

    My code does not do that.

    Another one problem is that I want to save my new created csv file with the same name as xsl file.

    Any helo would be appreciated.

    ' ---------------------- 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 = ";"
    'Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
    '"Export To Text File")
    'csvPath = InputBox("Enter the full path to export CSV files to: ")

    csvPath = GetFolderName("Choose the folder to export CSV files to:")
    If csvPath = "" Then
        MsgBox ("You didn't choose an export directory. Nothing will be exported.")
        Exit Sub
    End If

    For Each wsSheet In Worksheets
    wsSheet.Activate
    nFileNum = FreeFile
    Open csvPath & "\" & _
      wsSheet.Name & ".csv" For Output As #nFileNum
    ExportToTextFile CStr(nFileNum), Sep, False
    Close nFileNum
    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

     

     

     

     

     

    Wednesday, March 27, 2013 12:24 PM

Answers

  • I'm going to guess that code is more than 10 years old. With the built-in file dialogs provided by Application.FileDialog and the objects and methods provided by the Windows Scripting Runtime this simple task could be much, much easier.

    The following code accomplishes the same thing in a much simpler manner. You will need to add a reference to the Windows Scripting Runtime (Tools > References). For further understanding, see the following:

    ' Getting a folder is very easy with the built-in FileDialog method
    Public Function GetFolderName(ByVal Title As String) As String
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = Title
            If .Show Then
                GetFolderName = .SelectedItems(1)
            End If
        End With
    End Function
    
    Sub DoTheExport()
        Dim outputFolder As String
        Dim outputFile As String
        Dim sep As String
        Dim wsIndex As Long
        Dim fso As New FileSystemObject
        
        sep = ";"
        
        outputFolder = GetFolderName("Choose the folder to export CSV files to")
        If outputFolder = "" Then
            MsgBox ("You didn't choose an export directory. Nothing will be exported.")
            Exit Sub
        End If
        
        For wsIndex = 1 To Worksheets.Count
            outputFile = fso.BuildPath(outputFolder, _
                fso.GetBaseName(ThisWorkbook.FullName) & wsIndex & ".csv")
            ExportDelimited Worksheets(wsIndex), outputFile, sep
        Next
        
    End Sub
    
    Public Sub ExportDelimited( _
        ByVal Worksheet As Worksheet, _
        ByVal FileName As String, _
        ByVal Separator As String)
        
        Dim strValues() As String
        Dim colCount As Long, iCol As Long, iRow As Long
        Dim oRange As Range
        Dim fso As New FileSystemObject
        Dim tsOut As TextStream
        
        Set oRange = Worksheet.UsedRange
        colCount = oRange.Columns.Count
        
        ReDim strValues(colCount - 1)
        Set tsOut = fso.CreateTextFile(FileName)
        
        For iRow = 1 To oRange.Rows.Count
            For iCol = 1 To colCount
                strValues(iCol - 1) = CStr(oRange.Cells(iRow, iCol).Value)
            Next
            tsOut.WriteLine Join(strValues, Separator)
        Next
        
        tsOut.Close
        Set tsOut = Nothing
        
    End Sub


    Joshua Honig
    Learn more about data programming at bytecomb.com


    Wednesday, March 27, 2013 1:30 PM
  • You can use my free Add ;]

    XLS to CSV Add-in


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Wednesday, March 27, 2013 2:18 PM

All replies

  • I'm going to guess that code is more than 10 years old. With the built-in file dialogs provided by Application.FileDialog and the objects and methods provided by the Windows Scripting Runtime this simple task could be much, much easier.

    The following code accomplishes the same thing in a much simpler manner. You will need to add a reference to the Windows Scripting Runtime (Tools > References). For further understanding, see the following:

    ' Getting a folder is very easy with the built-in FileDialog method
    Public Function GetFolderName(ByVal Title As String) As String
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = Title
            If .Show Then
                GetFolderName = .SelectedItems(1)
            End If
        End With
    End Function
    
    Sub DoTheExport()
        Dim outputFolder As String
        Dim outputFile As String
        Dim sep As String
        Dim wsIndex As Long
        Dim fso As New FileSystemObject
        
        sep = ";"
        
        outputFolder = GetFolderName("Choose the folder to export CSV files to")
        If outputFolder = "" Then
            MsgBox ("You didn't choose an export directory. Nothing will be exported.")
            Exit Sub
        End If
        
        For wsIndex = 1 To Worksheets.Count
            outputFile = fso.BuildPath(outputFolder, _
                fso.GetBaseName(ThisWorkbook.FullName) & wsIndex & ".csv")
            ExportDelimited Worksheets(wsIndex), outputFile, sep
        Next
        
    End Sub
    
    Public Sub ExportDelimited( _
        ByVal Worksheet As Worksheet, _
        ByVal FileName As String, _
        ByVal Separator As String)
        
        Dim strValues() As String
        Dim colCount As Long, iCol As Long, iRow As Long
        Dim oRange As Range
        Dim fso As New FileSystemObject
        Dim tsOut As TextStream
        
        Set oRange = Worksheet.UsedRange
        colCount = oRange.Columns.Count
        
        ReDim strValues(colCount - 1)
        Set tsOut = fso.CreateTextFile(FileName)
        
        For iRow = 1 To oRange.Rows.Count
            For iCol = 1 To colCount
                strValues(iCol - 1) = CStr(oRange.Cells(iRow, iCol).Value)
            Next
            tsOut.WriteLine Join(strValues, Separator)
        Next
        
        tsOut.Close
        Set tsOut = Nothing
        
    End Sub


    Joshua Honig
    Learn more about data programming at bytecomb.com


    Wednesday, March 27, 2013 1:30 PM
  • You can use my free Add ;]

    XLS to CSV Add-in


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Wednesday, March 27, 2013 2:18 PM