große Dateimenge zusammenfassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
hier eine mögliche Lösung für die erste Variante.
Mit Alt+F11 den VBA- Editor öffnen, dort Menü- Einfügen- Modul. Im sich dann öffnenden Codefenster diesen Code reinkopieren. Oben den Pfad zu Deinen Dateien und ggf. das Trennzeichen anpassen!
Dann zurück zu Excel, speichern, Alt+F8 und Makro ausführen.
Good Luck! Mit 360 Dateien hab ich es natürlich nicht probiert ;o) Aber die Anzahl der Blätter ist nur durch den Arbeitsspeicher begrenzt... Notfalls kannst Du alle 10 neu angelegte Blätter zwischenspeichern lassen.

Option Explicit
Public Sub TextImport()
Dim Datei
Dim DateiName As String
Dim Speichern As Boolean
Dim i As Long
'Pfad anpassen! Ohne Backslash am Ende!
Const Pfad = "D:\Pfad\zu\Deinen\CSV\Dateien"
'Trennzeichen anpassen!  (Tabulator: Delimiter=vbTab)
Const Delimiter = ";"
With Application.FileSearch 'Dateien suchen
    .LookIn = Pfad
    .Filename = "*.csv" 'nur CSV- Dateien
    .Execute
End With
'hier ggf. die Abfragen rausnehmen, wenns zu sehr stört
If Application.FileSearch.FoundFiles.Count = 0 Then MsgBox "Keine Dateien gefunden.", vbInformation Or vbOKOnly, "Pfad richtig?": Exit Sub
If MsgBox(Application.FileSearch.FoundFiles.Count & " Dateien zu importieren. Fortfahren?", vbQuestion Or vbYesNo, "Frage") = vbNo Then Exit Sub
If MsgBox("Soll nach jeweils 10 Dateien gespeichert werden?", vbQuestion Or vbYesNo) = vbYes Then Speichern = True
On Error GoTo Fehler
Application.ScreenUpdating = False
For Each Datei In Application.FileSearch.FoundFiles
  i = i + 1
  'Namen des Blattes aus Dateinamen erstellen
  'aus "c:\Ordner\Datei.csv" wird "Datei"
  DateiName = Mid(Datei, InStrRev(Datei, "\") + 1, Len(Mid(Datei, InStrRev(Datei, "\"))) - 5)
  If Len(DateiName) > 31 Then
    'Länger als 31 Zeichen darf er nicht sein
    DateiName = Left(DateiName, 31 - Len("_" & CStr(i))) & "_" & CStr(i)
  End If
  ActiveWorkbook.Worksheets.Add.Name = DateiName
  With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Datei, Destination:=Range("A1"))
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileOtherDelimiter = Delimiter
    .Refresh 'Abfrage ausführen
    .Delete  'und gleich wieder löschen
  End With
  If Speichern And (i \ 10 = i / 10) Then 'alle 10 Blätter speichern
    ActiveWorkbook.Save
    DoEvents
  End If
Next
Application.ScreenUpdating = True
Exit Sub
Fehler:
Application.ScreenUpdating = True
MsgBox "Fehler " & Err.Number & " :" & Err.Description, vbCritical Or vbOKOnly, "Mist!"
End Sub

Code eingefügt mit Syntaxhighlighter 3.0

PS: Rückmeldung wäre nett.

Hallo Micha,
es funktioniert alles fabelhaft. Da ich die erste Spalte als Text formatiert benötige, habe ich ein Makro aufgezeichnet, in dem ich nur eine csv-Datei importiere. Darauf konnte ich mir folgenden Code entnehmen, den ich vor Deine Zeile ".Refresh 'Abfrage ausführen" gesetzt habe.
.TextFileColumnDataTypes = Array(2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)

Funktioniert auch. Im Moment lasse ich mir mit der externen Software die 365 Dateien erstellen. Bisher hatte ich zum Test blos immer nur ca. fünf. Ich hoffe mal, das klappt dann später mit dem Arbeitsspeicher.
Aber noch einmal: Vielen, vielen Dank.
Sollte es später noch Schwierigkeiten geben, dann poste ich noch mal.
Gruß Oliver

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread