Macro-To Create 1 [.csv] using multiple excel

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 & ".csv" 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