Excel VBA - Kopieren Sie alle CSV von einem Ordner in vorhandene Arbeitsmappe als separate Arbeitsblätter

Question

Ich bin auf der Suche nach einem Makro erstellen, die alle CSV-Dateien aus einem Ordner und kopiert sie in eine bereits vorhandene Arbeitsmappe, wo alle Blätter haben Derselbe Name wie die CSV-Quelldatei.

Ich habe den Code unten gefunden (leider erinnere ich mich nicht, wo ich es genau gefunden habe und kann den Autor nicht zitieren) Im Moment macht es nur einen Teil von dem, was ich suche. Es ermöglicht dem Benutzer, den Ordner auszuwählen, in dem sich die CSV-Dateien befinden, erstellt jedoch eine neue Arbeitsmappe und kopiert die Dateien in diese. Ich möchte für das Makro auch den Benutzer auffordern, die Zielarbeitsmappe für die Dateien auszuwählen, in die kopiert werden soll.

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

Der folgende Code macht das, was Sie beschreiben; Das heißt, "nimmt alle CSV-Dateien aus einem Ordner und kopiert sie in eine bereits vorhandene Arbeitsmappe, in der alle Blätter den gleichen Namen wie die CSV-Quelldatei haben".

Um den Code zu erstellen, importierte ich zunächst eine der .csv Dateien mit dem Makro-Recorder, und dann den Code geändert, um den allgemeinen Fall mehrerer Dateien im selben Ordner zu behandeln. Ich habe auch viel unnötigen Code entfernt. Sie sollten diesen Code an Ihre Bedürfnisse anpassen können.

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