Dateien aus Verzeichnissen automatisiert einlesen

Sub Auswertung() ' Auswertung Makro ' Tastenkombination: Strg+j With ActiveSheet.QueryTables.Add(Connection:= _ "TEXT;ergebnisdataI.asc" _ , Destination:=Range("A1")) .Name = "ergebnisdataI" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = xlWindows .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = True .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) .Refresh BackgroundQuery:=False End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
das ganze ist zwar ungetestet, weil ich keine ASC-Dateien habe,... sollte aber tun.

ub Import_ASC_Files()
Dim i As Long, TotFiles As Long
Dim gefFile As String, dname As String
Dim Suchpfad As String, suchbegriff As String, DateiForm As String
Dim oldStatus As Variant
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
DateiForm = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.asc")
If DateiForm = "" Then Exit Sub
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
'Alle Tabellen löschen bis auf eine
Application.DisplayAlerts = False
For i = Worksheets.Count To 2 Step -1
    Worksheets(i).Delete
Next
Application.DisplayAlerts = True
With Application.FileSearch
    .LookIn = Suchpfad
    .SearchSubFolders = True
    .Filename = DateiForm
    If .Execute() > 0 Then
        TotFiles = .FoundFiles.Count
        Application.StatusBar = "Total " & TotFiles & " gefunden"
        For i = 1 To .FoundFiles.Count
            gefFile = .FoundFiles(i)
            If i = 1 Then
                ActiveSheet.Name = "Test0" & i
            End If
            '-------------------
            'Dein Block
                With ActiveSheet.QueryTables.Add(Connection:= _
                    "TEXT;ergebnisdataI.asc" _
                    , Destination:=Range("A1"))
                    .Name = "ergebnisdataI"
                    .FieldNames = True
                    .RowNumbers = False
                    .FillAdjacentFormulas = False
                    .PreserveFormatting = True
                    .RefreshOnFileOpen = False
                    .RefreshStyle = xlInsertDeleteCells
                    .SavePassword = False
                    .SaveData = True
                    .AdjustColumnWidth = True
                    .RefreshPeriod = 0
                    .TextFilePromptOnRefresh = False
                    .TextFilePlatform = xlWindows
                    .TextFileStartRow = 1
                    .TextFileParseType = xlDelimited
                    .TextFileTextQualifier = xlTextQualifierDoubleQuote
                    .TextFileConsecutiveDelimiter = False
                    .TextFileTabDelimiter = False
                    .TextFileSemicolonDelimiter = False
                    .TextFileCommaDelimiter = True
                    .TextFileSpaceDelimiter = False
                    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
                    .Refresh BackgroundQuery:=False
                End With
            '---------
            'Ende deines Blockes
            Worksheets.Add
            If i < 10 Then
                ActiveSheet.Name = "Test0" & i
            Else
                ActiveSheet.Name = "Test" & i
            End If
        Next i
    End If
End With
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 1.16

Gruss Rainer

Hallo,
nachdem ich schon angefangen habe, hier das ganze Stück nochmal.
Alle Daten werden eingelesen und in jeweils ein Sheet gespeichert.
Viel Spass beim einarbeiten :-).
Für mich ist jetzt Feierabend.

Option Explicit
Sub Import_ASC_Files()
'(C) Ramses
'liest all DAten von ASC Files in beliebig vielen Subfolders ein
'und schreibt alle Daten eines Subfolders in ein EXCEL-Sheet
'Für jeden Subfolder wird ein neues Sheet erstellt
'-------------
Dim i As Long, n As Integer, m As Integer, intTotFiles As Long, fSlash As Integer
Dim txtlines As Long, totFiles As Long, textArr() As Variant
Dim gefFile As String, dname As String
Dim Suchpfad As String, suchbegriff As String, DateiForm As String
Dim tmpFoName As String, tmpFoNameFirst As String, Text1 As String
Dim si As Integer, myDiv As Boolean
Dim oldStatus As Variant
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", "C:\")
If Suchpfad = "" Then Exit Sub
DateiForm = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.asc")
If DateiForm = "" Then Exit Sub
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
myDiv = False
'Alle Tabellen löschen bis auf eine
Application.DisplayAlerts = False
For i = Worksheets.Count To 2 Step -1
    Worksheets(i).Delete
Next
Application.DisplayAlerts = True
Close #1
With Application.FileSearch
    .LookIn = Suchpfad
    'Unterordner durchsuchen = ".SearchSubFolders = True" !!!
    .SearchSubFolders = False
    .Filename = DateiForm
    If .Execute() > 0 Then
        totFiles = .FoundFiles.Count
        Application.StatusBar = "Total " & totFiles & " gefunden"
        For i = 1 To .FoundFiles.Count
            gefFile = .FoundFiles(i)
                If i = 1 Then
                    'FolderName aufnehmen
                    tmpFoName = gefFile
                    For n = 1 To Len(tmpFoName) - 5
                        If Mid(tmpFoName, n, 1) = "\" Then
                            fSlash = n
                        End If
                    Next n
                    tmpFoNameFirst = Left(tmpFoName, fSlash)
                    ActiveSheet.Name = "Test0" & i
                Else
                    tmpFoName = gefFile
                    For n = 1 To Len(tmpFoName) - 5
                        If Mid(tmpFoName, n, 1) = "\" Then
                            fSlash = n
                        End If
                    Next n
                    tmpFoName = Left(tmpFoName, fSlash)
                End If
                If i = 1 Then
                    Debug.Print "Start 1. Sequenz"
                    Debug.Print gefFile
                    Open gefFile For Input As #1
                    'Die anzahl ist nötig um die Grösse des Arrays zu deklarieren
                    'Zähler auf 0 setzen
                    txtlines = 0
                    Do While Not EOF(1)    ' Schleife bis Dateiende.
                        Input #1, Text1    ' Hilfsvariable zum einlesen verwenden
                        'Zähler hochzählen
                        txtlines = txtlines + 1
                    Loop
                    'Schliessen der Datei weil Dateiende erreicht wurde
                    Close #1
                    'Erneutes Öffnen um zum Dateianfang zu kommen
                    Open gefFile For Input As #1    ' Datei zum Einlesen öffnen.
                    'Array neu auf die Anzahl der Linien initialisieren
                    ReDim textArr(txtlines)
                    'Einlesen der Dateien in das Array
                    For n = 1 To txtlines
                        Line Input #1, textArr(n)
                    Next n
                    'Schreiben in Tabelle
                    For m = 1 To UBound(textArr())
                        Debug.Print ActiveSheet.Cells(65536, 1).End(xlUp).Row
                        ActiveSheet.Cells(ActiveSheet.Cells(65536, 1).End(xlUp).Row + 1, 1) = textArr(m)
                    Next m
                    ReDim textArr(0)
                    Debug.Print "1 Ende"
                Else
                    If tmpFoName = tmpFoNameFirst Then
                        Debug.Print "Start nächste Datei Sequenz"
                        Debug.Print gefFile
                        Close #1
                        '-------------------
                        'Datei öffnen zum einlesen in ein Array
                        Open gefFile For Input As #1
                        'Die anzahl ist nötig um die nächste Grösse des Arrays zu deklarieren
                        'Zähler auf 0 setzen
                        txtlines = 0
                        Do While Not EOF(1)    ' Schleife bis Dateiende.
                            Input #1, Text1    ' Hilfsvariable zum einlesen verwenden
                            'Zähler hochzählen
                            txtlines = txtlines + 1
                        Loop
                        'Schliessen der Datei weil Dateiende erreicht wurde
                        Close #1
                        'Erneutes Öffnen um zum Dateianfang zu kommen
                        Open gefFile For Input As #1    ' Datei zum Einlesen öffnen.
                        'Array Anzahl definieren
                        'Array neu auf die Anzahl der Linien initialisieren
                        ReDim textArr(txtlines)
                        'Einlesen der Dateien in das Array
                        For n = 1 To txtlines
                            Line Input #1, textArr(n)
                        Next n
                        Close #1
                        'Schreiben in Tabelle
                        For m = 1 To UBound(textArr())
                            ActiveSheet.Cells(ActiveSheet.Cells(65536, 1).End(xlUp).Row + 1, 1) = textArr(m)
                        Next m
                        ReDim textArr(0)
                    Else
                        Debug.Print "Start Sequenz Neuer Ordner"
                        Debug.Print gefFile
                        '-------------------
                        'Es wurde ein File aus einem anderen Ordner geöffnet
                        'Neue Tabelle anlegen und Folder neu bestimmen
                        tmpFoNameFirst = tmpFoName
                        'Trennt die bisherigen Daten in Spalten auf
                        Columns("A:A").Select
                        Selection.TextToColumns Destination:=Range("A1"), Semicolon:=True
                        Worksheets.Add
                        If i < 10 Then
                            ActiveSheet.Name = "Test0" & i
                        Else
                            ActiveSheet.Name = "Test" & i
                        End If
                    End If
                End If
        Next i
    End If
End With
ReDim textArr(0)
'für den letzten Ordner
'Trennt die Daten in Spalten auf
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), Semicolon:=True
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 1.16

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Dateien aus Verzeichnissen automatisiert einlesen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread