Excel的VBA - 从一个文件夹复制所有CSV到现有的工作簿作为单独的工作

Question

我期待创造了一个宏以从一个文件夹，并将它们复制所有的.csv文件到一个预先存在的工作簿，所有的表都与源.csv文件同名。

我发现下面的代码（不幸的是，我不记得在那里我恰好发现它并不能引用作者的）现在它只做什么我要找的一部分。它允许用户选择.csv文件所在的文件夹，但会创建一个新的工作簿并将文件复制到该文件夹​​中。我希望宏也提示用户选择要复制到的文件的目标工作簿。

Option Explicit 

Sub csvCopier() 

Dim wkb As Workbook 
Dim wksDest As Worksheet 
Dim strData As String 
Dim x As Variant 
Dim Cnt As Long 
Dim r As Long 
Dim c As Long 
Dim i As Long 
Dim myPath As String 
Dim myFile As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 

'Optimize Macro Speed 
    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 

'Retrieve Target Folder Path From User 
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

With FldrPicker 
    .Title = "Select A Target Folder" 
    .AllowMultiSelect = False 
    If .Show <> -1 Then GoTo NextCode 
    myPath = .SelectedItems(1) & "\" 
End With 

'In Case of Cancel 
NextCode: 
    myPath = myPath 
    If myPath = "" Then GoTo ResetSettings 

'Target File Extension (must include wildcard "*") 
    myExtension = "*.csv*" 

'Target Path with Ending Extention 
    myFile = Dir(myPath & myExtension) 

If Right(myPath, 1) <> "\" Then myPath = myPath & "\" 

myFile = Dir(myPath & "*.csv") 

Do While Len(myFile) > 0 

    Cnt = Cnt + 1 

    If Cnt = 1 Then 
     Set wkb = Workbooks.Add(xlWBATWorksheet) 
    End If 

    Open myPath & myFile For Input As #1 

     Set wksDest = wkb.Worksheets.Add 

     wksDest.Name = Left(myFile, InStr(1, myFile, ".csv") - 1) 

     r = 2 
     c = 1 
     Do Until EOF(1) 
      Line Input #1, strData 
      x = Split(strData, ",") 
      For i = LBound(x) To UBound(x) 
       Cells(r, c).Value = x(i) 
       c = c + 1 
      Next i 
      r = r + 1 
      c = 1 
     Loop 

    Close #1 

    myFile = Dir 

Loop 

    If Cnt > 0 Then 
    Application.DisplayAlerts = False 
    wkb.Worksheets(wkb.Worksheets.Count).Delete 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    MsgBox "Completed...", vbInformation 
    Else 
    Application.ScreenUpdating = True 
    MsgBox "No CSV files found...", vbExclamation 
    End If 

ResetSettings: 
'Reset Macro Optimization Settings 
Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub 

Answer 1

下面的代码完成你所描述的任务;这是它“从一个文件夹，并将它们复制通吃的.csv文件到一个预先存在的工作簿，所有的表都具有相同的名称作为源.csv文件”。

为了生成代码，我首先使用宏记录器导入.csv文件之一，然后修改代码以处理同一文件夹中多个文件的一般情况。我也删除了很多不必要的代码。您应该能够修改此代码以满足您的需求。

Option Explicit 
Sub csvToSheets() 
Dim wk As Workbook, sh As Worksheet, s As String 
Const path = "C:\test\" 
    s = Dir(path & "*.csv") 
While s <> "" 
    ThisWorkbook.Worksheets.Add 
    Set sh = ActiveSheet 


    With sh.QueryTables.Add(Connection:="TEXT;" & path & s, _ 
     Destination:=Range("$A$1")) 
     .Name = s 
     .TextFileParseType = xlDelimited 
     .TextFileCommaDelimiter = True 
     .Refresh BackgroundQuery:=False 
    End With 
    sh.Name = Left(s, Len(s) - 4) 
    s = Dir() 
Wend 
End Sub