oeffnen grosser Dateien in Excel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
probier mal aus
Option Base 1
Option Explicit

Sub Read_External_CSV_TXT_File_with_variable_Divider_into_Sheet()
    'by Ramses
    'Liest aus einer TXT oder CSV Datei eine definierte Anzahl Spalten ein
    'Sinnvoller Einsatz wenn die Datei mehr als 256 Spalten umfasst
    'weil diese Dateien nicht in EXCEL eingelesen werden können
    'Start Code
    'Variable für die Statusbar
    Dim oldStatus As Variant
    Dim i As Long, Qe As Long, ImportNr As Long
    Dim TextArr As Variant
    Dim addToNew As Boolean
    Dim ImportName As String
    'Variablen für den Umwandlungsprozess des TextArrays
    Dim cc As Integer, cr As Long, maxCol As Integer, maxLine As Long, tmpline As Long
    Dim ArrRun As Long, startCounter As Variant, endCounter As Variant
    Dim tmpString As String, findChr As String, fileName As String
    Dim transArr As Integer
    'Fehlerbehandlung aktivieren
    On Error GoTo myErrorHandler
    'Tabellenname für die zu importierenden Daten
    'Dieser wird fortlaufend hochgezählt bei mehr als 65536 Datensätzen
    ImportName = "Import Tabelle"
    ImportNr = Worksheets.count
    'Zu öffnende Datei
    fileName = Application.GetOpenFilename("Text Files (*.txt, *.csv), *.txt, *.csv", 1, "Import Datei", "Öffnen", False)
    If fileName = "Falsch" Then
        MsgBox "Abbruch"
        Exit Sub
    End If
    'Variable für das zu ersetzende Zeichen
    'Hier eventuell anpassen
    findChr = InputBox("Welches Trennzeichen wird in der Datei verwendet", "Trennzeichen", ";")
    If findChr = "" Then
        MsgBox "Abbruch"
        Exit Sub
    End If
    'Kontrolle der Zeit. Kann gelöscht werden
    Debug.Print "Start Maxline: " & Now
    'Prüfen ob das Trennzeichen in der ersten Zeile zur Definition
    'der Spaltenüberschriften identifiziert werden kann
    Open fileName For Input As #1 ' Datei zum Einlesen öffnen.
    'Einlesen der ersten Zeile und Prüfung ob Spalten identifiziert werden können
    Line Input #1, tmpString
    TextArr = Split(tmpString, findChr)
    If UBound(TextArr) = 0 Then
        Qe = MsgBox("In der ersten Zeile der Datei: " & fileName & " konnte das Trennzeichen nicht identifizert werden, " & vbCrLf & _
            "der Datenimport wird daher abgebrochen." & vbCrLf & _
            "Bitte kontrollieren Sie das Datentrennzeichen", vbOKOnly + vbCritical, "Abbruch")
        Exit Sub
    End If
    'Berechnen wieviele "Spalten" maximal in der Datei vorhanden sind
    maxCol = 0
    maxLine = 0
    tmpline = 1
    Do While Not EOF(1)
        Line Input #1, tmpString
        TextArr = Split(tmpString, findChr)
        If UBound(TextArr) > maxCol Then
            maxCol = UBound(TextArr)
        End If
        maxLine = maxLine + 1
    Loop
    Debug.Print "Ende Maxline: " & Now
    Close #1
    'Aufforderung welche Spalten benötigt werden
    startCounter = InputBox("Ab welcher Spalte soll mit dem einlesen begonnen werden?", _
        "Maximale Spaltenzahl = " & maxCol & " bei " & maxLine & " Datensätzen", 1)
    If startCounter = "" Or Not IsNumeric(startCounter) Then
        MsgBox "Abbruch. Falsche Spaltenzahl oder ungültiger Wert"
        Exit Sub
    End If
    endCounter = InputBox("Wieviele Spalten sollen nach Spalte " & startCounter & " eingelesen werden?", _
        "Maximale Spaltenzahl = " & maxCol - Cint(startCounter) & " bei " & maxLine & " Datensätzen", 1)
    If endCounter = "" Or Not IsNumeric(endCounter) Then
        MsgBox "Abbruch. Falsche Spaltenzahl oder ungültiger Wert"
        Exit Sub
    End If
    If maxLine > 65536 Then
        addToNew = False
        Qe = MsgBox("Es können nicht alle Datensätze in das aktive Tabellenblatt eingelesen werden" & vbCrLf & _
            "Sollen die Datensätze von " & maxLine - 65536 & " bis " & maxLine & " auf weitere Tabellen aufgeteilt werden ?", _
            vbYesNo + vbCritical + vbDefaultButton1, "Datensätze total: " & maxLine)
        'Aufteilen auf mehrere Tabellen
        If Qe = vbYes Then addToNew = True
    End If
    transArr = MsgBox("Sollen die Daten transponiert werden?", vbQuestion + vbYesNo + vbDefaultButton2, _
        "Transponieren = von Horizontal nach Vertikal umstellen")
    If Cint(endCounter) - Cint(startCounter) > 255 Then
        MsgBox "Mehr als 255 Spalten können nicht eingelesen werden"
        Exit Sub
    End If
    Debug.Print "Start Einlesen: " & Now
    'Schliessen einer geöffneten Datei
    Close #1
    Open fileName For Input As #1 ' Datei zum Einlesen öffnen.
    'Status der Anzeige aufnehmen
    oldStatus = Application.StatusBar
    'Bildschirmaktualisierung ausschalten
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    'Einlesen der Dateien in das Array
    ArrRun = 1
    cr = 1
    cc = 1
    'Import Sheet anlegen
    With Worksheets.Add
        .Select
        .name = ImportName & " " & ImportNr
        .Move after:=Worksheets(Worksheets.count)
    End With
    If transArr = vbNo Then
        Do While Not EOF(1)
            Line Input #1, tmpString
            TextArr = Split(tmpString, findChr)
            Application.StatusBar = "Datenimport in """ & ImportName & " " & ImportNr & """: Datensatz " & tmpline & " von " & maxLine & " wird importiert"
            'Falls ein Datensatz weniger Spalten zur Verfügung haben sollte
            '= Fehlerhafter Datenexport oder Datenaufbau
            On Error Resume Next
            For i = Cint(startCounter) + 1 To Cint(endCounter) + Cint(startCounter)
                Cells(cr, cc) = TextArr(i)
                cc = cc + 1
            Next i
            On Error GoTo 0
            Erase TextArr
            cc = 1
            cr = cr + 1
            If cr > 65536 Then
                'Wenn neue Tabellenblätter angelegt werden sollen
                If addToNew = True Then
                    With Worksheets.Add
                        .Move after:=Worksheets(Worksheets.count)
                        'Nummer hochzählen
                        ImportNr = ImportNr + 1
                        'auswählen
                        .Select
                        'Importtabelle umbenennen
                        .name = ImportName & " " & ImportNr
                        'Titelzeile kopieren
                        Worksheets(ImportName & " " & ImportNr - 1).Rows(1).Copy .Range("A1")
                    End With
                    cr = 2
                Else
                    MsgBox "Einlesen der Daten wie gewünscht am Tabellenende gestoppt", vbOKOnly + vbInformation, "65535 Datensätze von " & maxLine & " eingelesen"
                    GoTo myErrorExit
                End If
            End If
            'Importnummer hochzählen
            tmpline = tmpline + 1
        Loop
    Else
        Do While Not EOF(1)
            Line Input #1, tmpString
            TextArr = Split(tmpString, ";")
            Application.StatusBar = "Datenimport in """ & ImportName & " " & ImportNr & """: Datensatz " & tmpline & " von " & maxLine & " wird importiert"
            'Falls ein Datensatz weniger Spalten zur Verfügung haben sollte
            '= Fehlerhafter Datenexport oder Datenaufbau
            On Error Resume Next
            For i = Cint(startCounter) + 1 To Cint(endCounter) + Cint(startCounter)
                Cells(cr, cc) = TextArr(i)
                cr = cr + 1
            Next i
            On Error GoTo 0
            'Array löschen
            Erase TextArr
            cc = cc + 1
            'Bei mehr als 255 Spalten wird umgebrochen und 2 Zeilen unterhalb des
            'letzten Eintrages in einer zeile mit der Transposition weitergemacht
            If cc = 255 Then
                cc = 2
                cr = ActiveSheet.UsedRange.Rows.count + 3
                Range(Cells((cr - 2) - (Cint(endCounter) - Cint(startCounter)), 1), Cells(cr - 1, 1)).Copy Cells(cr, 1)
            Else
                cr = cr - Cint(endCounter)
            End If
            If cr + (Cint(endCounter) - Cint(startCounter)) > 65536 Then
                'Wenn neue Tabellenblätter angelegt werden sollen
                If addToNew = True Then
                    With Worksheets.Add
                        .Move after:=Worksheets(Worksheets.count)
                        'Nummer hochzählen
                        ImportNr = ImportNr + 1
                        'auswählen
                        .Select
                        'Importtabelle umbenennen
                        .name = ImportName & " " & ImportNr
                        'Titelzeile kopieren
                        Worksheets(ImportName & " " & ImportNr - 1).Rows(1).Copy .Range("A1")
                    End With
                    cr = 2
                Else
                    MsgBox "Einlesen der Daten wie gewünscht am Tabellenende gestoppt", vbOKOnly + vbInformation, "65535 Datensätze von " & maxLine & " eingelesen"
                    GoTo myErrorExit
                End If
            End If
            tmpline = tmpline + 1
        Loop
    End If
    'Tabellenüberschriften fett schreiben
    On Error Resume Next
    For i = 1 To ImportNr
        If transArr = vbNo Then
            With Worksheets(ImportName & " " & i)
                .Rows(1).Font.Bold = True
            End With
        Else
            With Worksheets(ImportName & " " & i)
                .Columns(1).Font.Bold = True
            End With
        End If
    Next i
    On Error GoTo 0
    myErrorExit:
    Close #1
    Application.StatusBar = oldStatus
    Application.ScreenUpdating = True
    Debug.Print "Ende einlesen: " & Now
    Exit Sub

    myErrorHandler:
    MsgBox Err.Number & ";" & Err.Description
    Resume myErrorExit
End Sub
'Ende Code Sequenz

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

oeffnen grosser Dateien in Excel

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread