Macro - To Create 1 .csv using multiple excel

Issue

I have more than one Excel Workbooks containing multiple worksheets in each of them.

It would be a great help if some one provide me a macro which helps to create (combine the information from) all the worksheets into one [sv] file.

These sheets should be combined/appended into single [sv] file, in the same order these worksbooks appear in a folder, and the order of these sheets should be maintained as they appear in these workbooks.

The macro should ask for a delimiter/separator specific to the user and the input and output path should also be based on my selection.

It would be great if the output [sv] file is names as "foldername" + "Outpusv"

Thank you,

Solution

Purpose:

To create a csv file by extracting data from all sheets of all workbook in a given folder

1. The code allow user to select the delimiter for the csv file

2. The code allow user to select the folder in which the *.xl* files are

3. The code allow user to select the output folder

4. The name of the csv file would be same as the folder in which the excel files were.

Assumptions:

1. Allow a user to select a folder and process all *.xl* filesAssumptions:

2. The excel workbook starts with a letter and DOES NOT start with a number. The names are like book11.xls, or book12_17.xls, book.xls. The naming is important for sorting.

3. The Sheets in each book are named in such manner that they can be sorted in right manner. The sheets are named as Trial, Trial1, Trial21 etc. It is again important for sorting

Option Explicit ' ---------------------- 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 thisWB As Workbook ' this workbook Dim tempSheet As Worksheet ' a temp sheet that would be created in this workbook Dim Sep As String ' delimiter Dim csvPath As String 'full path for csv Dim xlsPath As String 'full path for xls files Dim xlFilesInPath As String 'xl files in the xls path defined Dim sOutPutFile As String 'the folder from which the xls files are processed Dim nFileNum As Integer 'handle for csv file Dim lWBRow As Long ' a temp variable to keep track of row for workbook list Dim lSheetRow As Long ' a temp variable to keep track of row for sheet list Dim exportFile As Workbook ' workbook being exported Dim exportSheet As String ' worksheet being exported Dim Sheet As Object ' A variable to process sheets Dim bScreenUpdating As Boolean Dim bEnableEvents As Boolean Dim vCalculation As Variant Dim bDisplayAlerts As Boolean On Error GoTo Error_Handle With Application vCalculation = .Calculation bScreenUpdating = .ScreenUpdating bEnableEvents = .EnableEvents bDisplayAlerts = .DisplayAlerts End With 'Change ScreenUpdating, Calculation and EnableEvents With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' get separator Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File") If (Len(Trim(Sep)) <> 1) Then MsgBox "You did not select a single delimiter character or is missing. Nothing will be exported." GoTo End_Sub End If ' get the path of resulting CSV file 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.") GoTo End_Sub End If If Right(csvPath, 1) <> "" Then csvPath = csvPath & "" ' get the path of source xl* files xlsPath = GetFolderName("Choose the folder to export XLS files from:") If xlsPath = "" Then MsgBox ("You didn't choose an input directory. Nothing will be exported.") GoTo End_Sub End If If Right(xlsPath, 1) <> "" Then xlsPath = xlsPath & "" ' extract the name for output file which is the name of the folder of excel files sOutPutFile = Left(xlsPath, Len(xlsPath) - 1) Do While (InStr(1, sOutPutFile, "") > 0) If (Len(sOutPutFile) > InStr(1, sOutPutFile, "")) Then sOutPutFile = Mid(sOutPutFile, InStr(1, sOutPutFile, "") + 1) Loop If (InStr(1, sOutPutFile, ":") > 0) Then sOutPutFile = Mid(sOutPutFile, 1, InStr(1, sOutPutFile, ":") - 1) End If If (Len(sOutPutFile) < 1) Then MsgBox ("Invalid output file name. Nothing will be exported.") GoTo End_Sub End If sOutPutFile = sOutPutFile & "Output" 'If there are no Excel files in the folder exit the sub xlFilesInPath = Dir(xlsPath & "*.xl*") If xlFilesInPath = "" Then MsgBox "No files found. Nothing will be exported." GoTo End_Sub End If Set thisWB = ThisWorkbook Set tempSheet = Sheets.Add Cells(1, "A") = "File Name" Cells(1, "B") = "File Name Calc" Do While xlFilesInPath <> "" Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = xlFilesInPath xlFilesInPath = Dir() Loop With Range(Cells(2, "B"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "B")) .FormulaR1C1 = "=sortAbleName(RC[-1], ""_"", ""."")" .Copy .PasteSpecial xlPasteValues End With Columns("A:B").Select Selection.Sort _ Key1:=Range("B2"), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom nFileNum = FreeFile Open csvPath & sOutPutFile & sv" For Output As #nFileNum lWBRow = 2 xlFilesInPath = tempSheet.Cells(lWBRow, "A") Do While (xlFilesInPath <> "") Set exportFile = Nothing On Error Resume Next Set exportFile = Workbooks.Open(xlsPath & xlFilesInPath) DoEvents On Error GoTo Error_Handle If Not exportFile Is Nothing Then thisWB.Activate tempSheet.Select Cells(1, "C") = "Sheet Name" Cells(1, "D") = "Sheet Name Calc" Range(Cells(2, "C"), Cells(Rows.Count, "D")).Clear For Each Sheet In exportFile.Sheets Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = Sheet.Name Next Sheet With Range(Cells(2, "D"), Cells(Cells(Rows.Count, "C").End(xlUp).Row, "D")) .FormulaR1C1 = "=sortAbleName(RC[-1])" .Copy .PasteSpecial xlPasteValues End With Columns("C:D").Select Selection.Sort _ Key1:=Range("D2"), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom lSheetRow = 2 exportSheet = Cells(lSheetRow, "C") Do While (exportSheet <> "") exportFile.Activate Sheets(exportSheet).Select ExportToTextFile CStr(nFileNum), Sep, False thisWB.Activate tempSheet.Select lSheetRow = lSheetRow + 1 exportSheet = Cells(lSheetRow, "C") Loop Else MsgBox "Unable to open " & xlsPath & xlFilesInPath & ". File skipped." End If On Error Resume Next exportFile.Close False DoEvents On Error GoTo Error_Handle Set exportFile = Nothing lWBRow = lWBRow + 1 thisWB.Activate xlFilesInPath = tempSheet.Cells(lWBRow, "A") Loop GoTo End_Sub Error_Handle: MsgBox Err.Description End_Sub: On Error Resume Next Close nFileNum thisWB.Activate Application.bDisplayAlerts = False tempSheet.Delete Set exportFile = Nothing Set tempSheet = Nothing Set thisWB = Nothing With Application vCalculation = .Calculation = vCalculation .ScreenUpdating = bScreenUpdating .EnableEvents = bEnableEvents Application.bDisplayAlerts = bDisplayAlerts End With On Error GoTo 0 End Sub Function sortAbleName(targetString As String, Optional separator As String = "", Optional ignoreFromChar As String = "") As String Dim tempString As String Dim tempNum As String Dim ignoredChar As String tempString = targetString If (ignoreFromChar <> "") Then If (InStrRev(tempString, ignoreFromChar) > 0) Then ignoredChar = Mid(tempString, InStrRev(tempString, ignoreFromChar)) If (Len(tempString) > Len(ignoredChar)) Then tempString = Left(tempString, Len(tempString) - Len(ignoredChar)) Else tempString = "" End If End If End If Do While True If IsNumeric(Right(tempString, 1)) Then tempNum = Right(tempString, 1) & tempNum If Len(tempString) >= 1 Then tempString = Mid(tempString, 1, Len(tempString) - 1) Else tempString = "" End If Else Exit Do End If Loop If ((separator <> "") And (Right(tempString, Len(separator)) = separator)) Then tempString = sortAbleName(Mid(tempString, 1, Len(tempString) - Len(separator))) Else End If sortAbleName = tempString & separator & Right("00000" & tempNum, 5) & ignoredChar End Function 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 Dim bScreenUpdating As Boolean bScreenUpdating = Application.ScreenUpdating 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 WholeLine = WholeLine & Cells(RowNdx, ColNdx).Value & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #nFileNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = bScreenUpdating End Sub

Note

Thanks to rizvisa1 for this tip on the forum.