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

我希望创建一个宏，从一个文件夹中获取所有.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

---

下面的代码与您描述的相同；也就是说，它从一个文件夹中获取所有.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

---

它创建了一个新工作簿，但没有保存？@jsotola它创建了一个新工作簿，但没有自动保存。我希望代码提示用户首先打开一个现有工作簿，该工作簿将用作副本的目标。所以，只需使用vba对打开的工作簿进行web搜索。。。应该有很多例子。我尝试了您的代码，但每当打开多个工作簿（例如PERSONAL.XLSB和目标工作簿）时，宏就会在一本书中创建空白工作表，并将所有数据复制到另一本书中的一张工作表上。我做了一个小改动，使用sh变量而不是ActiveSheet，因为调试ActiveSheet时可能会出现问题。请记住，我的代码只是为了让您开始。我希望这对你有帮助。它对你有帮助！谢谢你很高兴你得到了帮助。如果你认为你的问题已经得到了回答，请将其标记为已回答