none
Convert a serie of specific tabs of my excel file into separate CSV files RRS feed

  • Question

  • Hi everyone,

    I currently work on an excel file with 13 tabs among which 8 only must be exported into separate CSV files.

    I managed to find a macro which converts all the tabs of my workbook into separate CSV files and export them to the folder of my choice at the same time which is already a huge help. Now the bug is that there are these other tabs that are here to validate entry mistakes against the data that I entered in my actual target-tabs (the 8 that I truely need to export as CSV files).

    So, when I use the macro it creates CSV files for all my tabs even the ones I don't need which forces me to constantly go to the destination folder of the export to delete the unwanted CSV files.

    Now this is a process that I will have to repeat probably hundreds of time in the future so I am looking to enhance the macro so it only creates CSV files for these 8 tabs in my workbook and not the other tabs which are not necessary.

    FYI: the tabs always have the same name. Maybe that can help for the macro.

    Here is the current code that I use:

    ' ---------------------- 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 = 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
    
    
    
    

    Would anyone have the kindness to help me here?

    Cheers

    Wednesday, December 4, 2019 9:32 AM

All replies

  • Here is a version where you can specify the names of the sheets to be exported. It doesn't need the code at the top up to and including the line '---------------------- END Directory Chooser Helper Functions ---------------------- (recent Office applications have a file and folder picker dialog built in)

    Public Sub DoTheExport()
        Dim FName As Variant
        Dim Sep As String
        Dim wsSheet As Worksheet
        Dim nFileNum As Integer
        Dim csvPath As String

        Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
                       "Export To Text File")
        With Application.FileDialog(4) ' msoFileDialogFolderPicker
            .Title = "Choose the folder to export CSV files to:"
            If .Show Then
                csvPath = .SelectedItems(1)
            Else
                MsgBox "You didn 't choose an export directory. Nothing will be exported."
                Exit Sub
            End If
        End With

        ' Change the list of sheet names as needed
        For Each wsSheet In Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", _
                "Sheet5", "Sheet6", "Sheet7", "Sheet8"))
            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:
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, December 4, 2019 12:20 PM
  • It works perfectly.

    Thank you so much. Internet is really the best.

    Cheers mate.

    Wednesday, December 4, 2019 3:46 PM
  • Hello, it's me again.

    I was wondering if it's possible to modify that code to save the files in CSV UTF-8 format instead of regular CSV files. Does anyone has an idea on how to do that or if it's even possible?

    Edit: CSV UTF8 with bom*


    • Edited by charliecoch Friday, December 6, 2019 10:57 AM
    Friday, December 6, 2019 9:55 AM
  • Try this:

    Public Sub DoTheExport()
        Dim FName As Variant
        Dim Sep As String
        Dim wsSheet As Worksheet
        Dim s As Object
        Dim csvPath As String
    
        Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
                       "Export To Text File")
        With Application.FileDialog(4) ' msoFileDialogFolderPicker
            .Title = "Choose the folder to export CSV files to:"
            If .Show Then
                csvPath = .SelectedItems(1)
            Else
                MsgBox "You didn 't choose an export directory. Nothing will be exported."
                Exit Sub
            End If
        End With
    
        ' Change the list of sheet names as needed
        For Each wsSheet In Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", _
                "Sheet5", "Sheet6", "Sheet7", "Sheet8"))
            wsSheet.Activate
            Set s = CreateObject(Class:="ADODB.Stream")
            s.Type = 2 ' adTypeText
            s.Charset = "UTF-8"
            s.LineSeparator = -1 ' adCRLF
            s.Open
            ExportToTextFile s, Sep, False
            s.SaveToFile csvPath & "\" & wsSheet.Name & ".csv", 2 ' adSaveCreateOverWrite
        Next wsSheet
    End Sub
    
    Public Sub ExportToTextFile(s As Object, _
                                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))
            s.WriteText WholeLine, 1 ' adWriteLine
        Next RowNdx
    
    EndMacro:
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, December 6, 2019 2:32 PM
  • It works perfectly.

    Thank you so much! Have a great week :)

    I hope this topic will help people with the same issue in the future.


    • Edited by charliecoch Monday, December 9, 2019 8:42 AM
    Monday, December 9, 2019 8:42 AM