Große CSV-Daten in kleine Stückeln per Makro

Option Explicit
Option Base 1
Sub LargeFileImport()
Dim FileName        As String
Dim FileNum         As Integer
Dim ResultStr       As String
Dim wsSheet         As Worksheet
Dim strValues()     As String
Dim lngRows         As Long
Dim lngRow          As Long
Dim intSheet        As Integer
Dim Eingabe         As String
Dim SollRows        As String
Dim NeuRows         As String
Dim CopyRows        As String
Dim InsertRows      As String


'*************************************************************************************  
' Abfrage von maximalen Datenzeilen je Tabellenblatt  
'*************************************************************************************  
    SollRows = InputBox("Bitte geben Sie die maximale Zeilenanzahl ein:", "Maximale Zeilenanzahl")  
    If SollRows = "" Then Exit Sub  
        If IsNumeric(SollRows) Then
            NeuRows = SollRows
        Else
            If MsgBox("Sie haben keine Zahl eingeben!", vbOKOnly, "Maximale Zeilenanzahl") = vbOK Then  
            Exit Sub
        End If
    End If
    
    If MsgBox("Sie haben eine maximale Zeilenanzahl angegeben von: " & NeuRows, vbOKCancel, "Maximale Zeilenanzahl") = vbCancel Then  
        Exit Sub
    End If

'*************************************************************************************  
' Abfrage wieviele Datenzeilen als Header an Tabellenblatt-Anfang kopiert werden sollen  
'*************************************************************************************  
    CopyRows = InputBox("Bitte geben Sie die Zeilenanzahl für den zu kopierenden Spaltenkopf ein:", "Zeilenanzahl für Spaltenkopf")  
    If CopyRows = "" Then Exit Sub  
        If IsNumeric(CopyRows) Then
            InsertRows = CopyRows
        Else
            If MsgBox("Sie haben keine Zahl eingeben!", vbOKOnly, "Zeilenanzahl für Spaltenkopf") = vbOK Then  
            Exit Sub
        End If
    End If

    If MsgBox("Sie haben eine Zeilenanzahl für den zu kopierenden Spaltenkopf angegeben von: " & NeuRows, vbOKCancel, "Zeilenanzahl für Spaltenkopf") = vbCancel Then  
        Exit Sub
    End If
'*************************************************************************************  
' Ende aller Abfragen  
'*************************************************************************************  

   FileName = Application.GetOpenFilename("Textdateien " & _  
                  "(*.txt; *.csv;*.asc),*.txt; *.csv; *.asc")  

   If FileName = "" Or FileName = "Falsch" Then Exit Sub  
   FileNum = FreeFile()
   
   On Error GoTo ErrorHandler
   Open FileName For Input As #FileNum
   Application.ScreenUpdating = False
   Workbooks.Add template:=xlWorksheet

   lngRows = NeuRows
   lngRow = 1
   intSheet = 1
   ReDim strValues(lngRows, 1)

   Application.StatusBar = " Einlesen Blatt " & intSheet & " / 0 %"  

   Do While Seek(FileNum) <= LOF(FileNum)
      Line Input #FileNum, ResultStr
      If Left(ResultStr, 1) = "=" Then  
         strValues(lngRow, 1) = "'" & ResultStr  
      Else
         strValues(lngRow, 1) = ResultStr
      End If
      If lngRow < lngRows Then
         lngRow = lngRow + 1
         If (lngRow * 100 / lngRows) Mod 10 = 0 Then
            Application.StatusBar = " Einlesen Blatt " & intSheet & _  
                                    " / " & Int(lngRow * 100 / lngRows) & " %"  
         End If
      Else
         Application.StatusBar = " Schreibe Daten in Blatt " & intSheet  
         ActiveSheet.Range("A1:A" & lngRows) = strValues  
         ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)

         ReDim strValues(lngRows, 1)
         lngRow = 1
         intSheet = intSheet + 1
         Application.StatusBar = "Einlesen Blatt " & intSheet  
      End If
   Loop
   Close
   ActiveSheet.Range("A1:A" & lngRows) = strValues  
   
'*************************************************************************************  
' Beginn der Aufteilung in Spalten  
'*************************************************************************************  
   Dim strDelimiter As String
   Do
      strDelimiter = Application.InputBox("1  ==>    Tabulator " & Chr(13) & _  
                                          "2  ==>    Semikolon" & Chr(13) & _  
                                          "3  ==>    Komma" & Chr(13) & _  
                                          "4  ==>    Leerzeichen" & Chr(13) & _  
                                          "5  ==>    Andere" & Chr(13) & _  
                                          "Trennzeichen wählen", "1", Type:=1)  
   Loop Until CInt(strDelimiter) >= 0 And CInt(strDelimiter) <= 5

   If strDelimiter = 5 Then
      Dim strDelimOther As String
      strDelimOther = Application.InputBox("Bitte das verwendete Trennzeichen " _  
                                           & "eingeben" & Chr(13) & _  
                                           "00 ==> Abbruch ", _  
                                           "Trennzeichen wählen", Type:=2)  
      If strDelimOther = "00" Then GoTo ErrorHandler  
   End If

   intSheet = 0
   For Each wsSheet In ActiveWorkbook.Worksheets
      intSheet = intSheet + 1
      Application.StatusBar = "Bearbeiten von Blatt " & intSheet  
      With wsSheet
         .Range("A:A").TextToColumns Destination:=.Range("A1"), _  
                                     DataType:=xlDelimited, _
                                     TextQualifier:=xlDoubleQuote, _
                                     ConsecutiveDelimiter:=False, _
                                     Tab:=IIf(strDelimiter = "1", True, False), _  
                                     Semicolon:=IIf(strDelimiter = "2", True, False), _  
                                     Comma:=IIf(strDelimiter = "3", True, False), _  
                                     Space:=IIf(strDelimiter = "4", True, False), _  
                                     Other:=IIf(strDelimiter = "5", True, False), _  
                                     OtherChar:=IIf(strDelimiter = "5", strDelimOther, "")  
      End With
   Next wsSheet
ErrorHandler:
   Application.ScreenUpdating = True
   Application.StatusBar = "Fertig"  
End Sub

Sub splitten_als_csv() 
	Dim I_Sheets As Integer 
	Dim F_Name As String 
	Dim F_Path As String 

	F_Path = Application.InputBox("Pfad angeben")   

	For I_Sheets = 1 To Sheets.Count 
	F_Name = F_Path + Sheets(I_Sheets).Name + ".csv"   

	Sheets(I_Sheets).SaveAs Filename:=F_Name, FileFormat:= _ 
	xlCSV, CreateBackup:=False 

	Next I_Sheets 
End Sub