ich bin zur Zeit auf der Suche nach einer Lösung für den Import von 8760 CSV Dateien in eine einzelne Excel Datei.
Als Ansatz habe ich hier im Forumsarchiv von "Horst" folgenden Code gefunden und konnten diesen an meine Bedürfnisse soweit anpassen, dass das Makro das erledigt, was es soll :-)
Das Problem ist nur, dass beim Excel beim einlesen jeder einzelnen Datei verlangt, dass ich das Löschen der Zwischenablage bestätige.
Ich hatte bereits versucht durch das Einfügen des Befehls
application.cutcopymode = false
dies zu unterbinden, jedoch leider ohne Erfolg ... Wenn es nur ein paar Dateien wären, wäre diese Meldung ja nicht weiter schlimm, aber 8760 mal den Button zu klicken geht dann doch an die Geduldsgrenze ;-)
Sub CSV_Dateien_importieren()
' Daten aus CSV-Dateien einfügen, Daten sind durch Semicolon getrennt, _
Dezimalstelle ist Punkt
' im aktiven Blatt werden Daten aus CSV Dateien im gewählten Verzeichnis eingefügt
Dim wb As Workbook, wks As Worksheet, wbAktiv As Workbook, wksAktiv As Worksheet
Dim rngZelle As Range
Dim strVerzeichnis As String
Dim Dateiname As Variant, DateinameTXT As String
Const strZelleDatum As String = "A2" 'Zelle mit Datum in CSV-Datei
Const strBereich As String = "A2:B97" 'zu kopierender Bereich in CSV-Datei
Const lngZeilenBereich As Long = 96 'Anzahl Zeilen des kopierten Bereichs in CSV-datei
Dateiname = Application.GetOpenFilename(FileFilter:="CSV (*.csv), *.csv", _
Title:="CSV-Datei im Verzeichnis auswählen")
If Dateiname = False Then Exit Sub
strVerzeichnis = VBA.CurDir
Set wbAktiv = ActiveWorkbook
Set wksAktiv = ActiveSheet
'Nächste freie Zelle in Spalte B (2) am Ende suchen
Set rngZelle = wksAktiv.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
Dateiname = Dir(strVerzeichnis & Application.PathSeparator & "*.csv")
Application.ScreenUpdating = False
Do Until Dateiname = ""
'CSV-Datei temporär als txt-Datei kopieren
VBA.FileCopy Source:=Dateiname, Destination:=Left(Dateiname, Len(Dateiname) - 3) & "txt"
DateinameTXT = Left(Dateiname, Len(Dateiname) - 3) & "txt"
'Umbenannte Kopie öffnen
Application.Workbooks.OpenText Filename:=DateinameTXT, Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=True, _
Comma:=False, _
Space:=False, _
Other:=False, _
DecimalSeparator:=".", ThousandsSeparator:=","
Set wb = ActiveWorkbook
'Daten Kopieren
wb.Sheets(1).Range(strBereich).Copy
rngZelle.PasteSpecial Paste:=xlPasteValues
'Datum aus CSV-Datei in Spalte links von den Daten einfügen
wksAktiv.Range(rngZelle.Offset(0, -1), rngZelle.Offset(lngZeilenBereich - 1, -1)).Value _
= wb.Sheets(1).Range(strZelleDatum)
'Nächste Einfügezelle setzen
Set rngZelle = rngZelle.Offset(lngZeilenBereich, 0)
wb.Close savechanges:=False
'TXT-Kopie wieder löschen
VBA.Kill (DateinameTXT)
Dateiname = Dir
Loop
Application.ScreenUpdating = True
End Sub
Für jede Hilfe wäre ich sehr dankbar :)Beste Grüße!