Hallo Helmut,
teste mal, kann aber ein paar Minuten dauern.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub readBig_CSV()
Dim strFile As String, strName As String, strTmp As String
Dim lngIndex As Long, lngMaxRows As Long, lngC As Long, lngCol As Long, lngRowsCount As Long, lngCounter As Long
Dim objSh As Worksheet
Dim FF1 As Integer, lngCalc As Long
Dim vntTmp() As Variant, vntS As Variant
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
Const clngFirstRow = 2 'Zeile ab der eingefügt wird
Const clngMaxColumns As Long = 5 'Maximale Spaltenanzahl der CSV (kann auch mehr sein als in der CVS vorkommen!)
strFile = Application.GetOpenFilename("Text Dateien (*.csv; *.txt), *.csv; *.txt")
If strFile = CStr(False) Then GoTo ErrExit
lngIndex = 1
If Dir(strFile, vbNormal) <> "" Then
strName = Mid(strFile, InStrRev(strFile, "\") + 1)
strName = Left(strName, InStrRev(strName, ".") - 1)
lngMaxRows = Sheets(1).Rows.Count
Redim vntTmp(1 To lngMaxRows - clngFirstRow + 1, 1 To clngMaxColumns)
FF1 = FreeFile
Open strFile For Input As #FF1
Do While Not EOF(FF1)
Line Input #FF1, strTmp
lngRowsCount = lngRowsCount + 1
Loop
Close #FF1
FF1 = FreeFile
Open strFile For Input As #FF1
Do While Not EOF(FF1)
lngCounter = lngCounter + 1
Line Input #FF1, strTmp
vntS = Split(strTmp, ";")
For lngCol = 0 To Application.Min(UBound(vntS), clngMaxColumns - 1)
vntTmp(lngIndex, lngCol + 1) = vntS(lngCol)
Next
lngIndex = lngIndex + 1
If lngIndex > lngMaxRows - clngFirstRow + 1 Or lngCounter = lngRowsCount Then
lngIndex = 1
lngC = lngC + 1
If Not SheetExist(strName & "_" & CStr(lngC)) Then
Set objSh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
objSh.Name = strName & "_" & CStr(lngC)
Else
Set objSh = Sheets(strName & "_" & CStr(lngC))
End If
objSh.Cells(clngFirstRow, 1).Resize(lngMaxRows - clngFirstRow + 1, clngMaxColumns) = vntTmp
Redim vntTmp(1 To lngMaxRows - clngFirstRow + 1, 1 To clngMaxColumns)
End If
Loop
Close #FF1
Else
MsgBox "Datei nicht gefunden!"
End If
ErrExit:
If Err.Number <> 0 Then
MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = lngCalc
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function