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

以下代码执行您所描述的内容;就是它＆＃34;从一个文件夹中获取所有.csv文件并将它们复制到预先存在的工作簿中，其中所有工作表都与源.csv文件同名并且＃34;。

要生成代码，我首先使用宏录制器导入其中一个.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

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

1 个答案: