用于将文本文件导入到单独的Excel工作簿的VBA宏

Question

我有一个宏将一个文件夹中的所有文本文件导入到一个Excel工作表中。我现在想要的是宏应该将所有文件导入到文件夹中，但要导入到单独的Excel工作簿（单独的Excel文件）中。

我在这里附加宏，请帮忙！

P.S. ：这个宏不是由我写的。我在网上找到它，并做了一些必要的修改以适应我的需求。

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 

Answer 1

以下工程（上的.csv文件测试）：

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