VBA Macro for importing text files into separate Excel workbooks

Question

I have a macro that imports all the text files in one folder onto one Excel sheet. What I want now is that the macro should import all the files into the folder, but into separate Excel workbooks (separate Excel files).

I am attaching the macro here, please help!

P.S. : This macro is not written by me. I found it online, and made some necessary changes to suit my needs.

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long

    Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#Else
    Private Declare Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long

    Private Declare Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, _
        lpExitCode As Long) As Long
#End If

Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103

Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
    Dim hProg As Long
    Dim hProcess As Long, ExitCode As Long
    'fill in the missing parameter and execute the program
    If IsMissing(WindowState) Then WindowState = 1
    hProg = Shell(PathName, WindowState)
    'hProg is a "process ID under Win32. To get the process handle:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
    Do
        'populate Exitcode variable
        GetExitCodeProcess hProcess, ExitCode
        DoEvents
    Loop While ExitCode = STILL_ACTIVE
End Sub

Sub Merge_CSV_Files()
    Dim BatFileName As String
    Dim TXTFileName As String
    Dim XLSFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim DefPath As String
    Dim Wb As Workbook
    Dim oApp As Object
    Dim oFolder
    Dim foldername

    'Create two temporary file names
    BatFileName = Environ("Temp") & _
            "\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
    TXTFileName = Environ("Temp") & _
            "\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"

    'Folder where you want to save the Excel file
    'DefPath = Application.DefaultFilePath
    DefPath = ThisWorkbook.Path
        If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Set the extension and file format
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007 or higher
        FileExtStr = ".xlsx": FileFormatNum = 51
        'If you want to save as xls(97-2003 format) in 2007 use
        'FileExtStr = ".xls": FileFormatNum = 56
    End If

    'Name of the Excel file with a date/time stamp
    XLSFileName = DefPath & "MetaData Collated " & _
                  Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr

    'Browse to the folder with CSV files
    Set oApp = CreateObject("Shell.Application")
    Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
    If Not oFolder Is Nothing Then
        foldername = oFolder.Self.Path
        If Right(foldername, 1) <> "\" Then
            foldername = foldername & "\"
        End If

        'Create the bat file
        Open BatFileName For Output As #1
        Print #1, "Copy " & Chr(34) & foldername & "*.txt" _
                & Chr(34) & " " & TXTFileName
        Close #1

        'Run the Bat file to collect all data from the CSV files into a TXT file
        ShellAndWait BatFileName, 0
        If Dir(TXTFileName) = "" Then
            MsgBox "There are no csv files in this folder"
            Kill BatFileName
            Exit Sub
        End If

        'Open the TXT file in Excel
        Application.ScreenUpdating = False
        Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
                :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, _
                Space:=False, Other:=True, OtherChar:="|"

        'Save text file as a Excel file
        Set Wb = ActiveWorkbook
        Wb.SaveAs FileFormat:=FileFormatNum
        Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
        Application.DisplayAlerts = True

        Wb.Close savechanges:=False
        MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName

        'Delete the bat and text file you temporary used
        Kill BatFileName
        Kill TXTFileName

        Application.ScreenUpdating = True
    End If
End Sub

possible duplicate of [vba: Importing text file into excel sheet](http://stackoverflow.com/questions/11267459/vba-importing-text-file-into-excel-sheet) — Vidya Sagar, Jun 22 '15 at 05:19
What I posted and what you shared is indeed doing similar work. But what my macro is doing is taking all text files in one folder and then importing them in excel, one after the other. — Raghav Datta, Jun 22 '15 at 05:26
Now what I want it to do is to take a folder, import all excel files in a specific manner, into separate excel files. So if a folder has 10 .txt files, once the macro runs, it should have 10 .xlsx files as well. — Raghav Datta, Jun 22 '15 at 05:27

score 0 · Accepted Answer · answered Jun 22 '15 at 10:36

The following works (tested on .csv files):

Sub test()
    Convert "C:\"
End Sub

Sub Convert(strPath As String)
    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet
    Dim filename, newname

    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then Exit Sub
        sItem = .SelectedItems(1)
    End With
    Set fldr = Nothing

    filename = Dir(sItem & "\*.*")
    While (filename <> "")
        Set wbO = Workbooks.Open(sItem & "\" & filename)
        If (wbO Is Nothing) Then Exit Sub
        pos = InStrRev(filename, ".")
        newname = Mid(filename, 1, pos) + "xlsx"

        Set wbI = Workbooks.Add
        Set wsI = wbI.Sheets("Sheet1")

        wbO.Sheets(1).Cells.Copy wsI.Cells

        wbO.Close SaveChanges:=False
        wbI.SaveAs sItem & "\" & newname
        wbI.Close
        filename = Dir
    Wend
End Sub

VBA Macro for importing text files into separate Excel workbooks

1 Answers1