Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1428to1432
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

CSV Importieren

CSV Importieren
19.06.2015 14:54:12
Thomas
Hallo,
mit dem untenstehendem Makro importiere ich alle csv Dateien aus einem bestimmten Ordner. Ist es möglich alle CSV Dateien aus allen Unterordnern zu Importieren?
Ich habe z.B. den Hauptordner "Werte" und in diesem Ordner befinden sich auch eine variable Anzahl von Unterordnen. In jedem Unterordner befindet sich eine CSV Datei die ich Importieren möchte. So zusagen brauche ich alle CSV die In diesem Hauptordner incl. Unterordner sind in ein Excelblatt.
bekommt man dies hin? Cool wäre wenn ich den Haupt Ordner über eine Abfrage angeben könnte.
Liebe grüsse thomas
Sub csv_untereinander()
'(C) Ramses
'Liest alle CSV-Dateien in einem Verzeichnis ein
Dim Datei As String, freeRow As Long
Dim Qe As Integer
Dim PFAD As String
PFAD = "D:\werte\" 'ACHTUNG: Bachslash am Schluss
Datei = Dir(PFAD & "*.csv")
Qe = MsgBox("Zum Import muss die aktuelle Tabelle leer sein," & vbCrLf & _
"bzw. alle Daten der aktuellen Tabelle: "" " & ActiveSheet.Name & " "" werden gelöscht", _
vbYesNo + vbCritical, "CSV-Import starten ?")
If Qe = vbNo Then
MsgBox "CSV-Import abgebrochen"
Exit Sub
Else
Cells.Clear
End If
Do While Datei  ""
freeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & PFAD & Datei, Destination:=Range("A"  _
_
_
_
& freeRow))
.Name = Datei
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Datei = Dir()
Loop
End Sub

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: CSV Importieren
20.06.2015 12:32:59
fcs
Hallo Thomas,
mit den folgenden Anpassungen werden alle CSV-Dateien in den Unterordnern mit erfasst.
Die Liste der CVS-Dateien wird dabei über ein weiteres Makro in einem Array erstellt und dann abgearbeitet.
Option Explicit
'Quelle: http://www. _
herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: Franz Sielck 2010-08-07
Public lCount As Long, arrFiles() As String
Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, _
Optional FolderName As Boolean = False)
'1.Parameter Ordner, wo soll gesucht werden?
'2.Parameter Datei,* als Platzhalter verwenden,Optional leer ist alle
'3.Parameter mit Unterordner = True, Optional False ist ohne
'4.Parameter kompl. Pfad ausgeben = True, Optional nur Dateiname = False
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - optional inkl. Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
lCount = lCount + 1
ReDim Preserve arrFiles(1 To lCount)
arrFiles(lCount) = IIf(FolderName, FileItem, FileItem.Name)
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Sub csv_untereinander()
'(C) Ramses
'Liest alle CSV-Dateien in einem Verzeichnis ein
Dim Datei As Variant, freeRow As Long
Dim Qe As Integer
Dim PFAD As String
Qe = MsgBox("Zum Import muss die aktuelle Tabelle leer sein," & vbCrLf & _
"bzw. alle Daten der aktuellen Tabelle: "" " & ActiveSheet.Name & " "" werden gelöscht", _
_
vbYesNo + vbCritical, "CSV-Import starten ?")
If Qe = vbNo Then
MsgBox "CSV-Import abgebrochen"
Exit Sub
Else
Cells.Clear
End If
'Ordner auswählen
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.ButtonName = "Ordner wählen"
.Title = "Bitte Haupt-ordner mit CSV-Dateien auswählen"
.InitialView = msoFileDialogViewList
If .Show  False Then
PFAD = .SelectedItems(1)
Else
Exit Sub
End If
End With
'Dateinamen einlesen
Call ListFilesInFolder(SourceFolderName:=PFAD, _
DateiFormat:="*.CSV", IncludeSubfolders:=True, FolderName:=True)
If lCount = 0 Then
MsgBox "Keine CSV-Dateien gefuden"
Else
'Dateiliste abarbeiten
For Each Datei In arrFiles
freeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Datei, _
Destination:=Range("A" & freeRow))
.Name = Mid(Datei, InStrRev(Datei, "\") + 1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
Erase arrFiles: lCount = 0
End If
End Sub

Anzeige
gelöst Besten dank Franz
21.06.2015 16:26:36
Thomas
Hallo Franz,
besten Dank für die Hilfe dies spart mir stunden Arbeit besten dank.
PS. schaust Du mal bitte ob du das kopiermacro ändern kannst?
liebe grüsse Thomas

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige