Textdatei kürzen (Dos-Batchprogramm?)

move Kurz.txt Lang.txt

Const QUELLE As String = "D:\Test"  
Const ASCNAME As String = "KROS.ASC"  
Const ZIEL As String = "D:\Test"  
Const XLSNAME As String = "Kros"  

Sub Import()
x = Timer

Set fso = CreateObject("Scripting.FileSystemObject")  
If fso.FileExists(QUELLE & "\" & ASCNAME) Then  
    aZeilen = Split(fso.OpenTextFile(QUELLE & "\" & ASCNAME, 1).ReadAll, vbCrLf) 'gesamte ASC-Datei einlesen  

    If fso.FileExists(ZIEL & "\" & XLSNAME & "01.xls") Then fso.DeleteFile ZIEL & "\" & XLSNAME & "??.xls" 'XLS-Dateien löschen  

    iLetzte = UBound(aZeilen) 'Zeilenanzahl - 1  
    iDNr = 101 'Zähler für Dateinamen (nur letzte 2 Stellen verwenden)  
    iZeile = 0 'Index für auszulesende Zeilen  
    iMaxDatei = Int((iLetzte + 1) / 65536) 'Anzahl "volle" Tabellen ...  
    If (iMaxDatei * 65536) < (iLetzte + 1) Then iMaxDatei = iMaxDatei + 1 '... und noch eine für den Rest  
    Dim W As Workbook
    
    For iDatei = 1 To iMaxDatei - 1 'Alle vollen Tabellen ...  
        Set W = Workbooks.Add
        W.Activate
        With W.Worksheets(1)
            For j = 1 To 65536
                .Cells(j, 1) = aZeilen(iZeile)
                iZeile = iZeile + 1
            Next
        End With
        AufteilenUndSpeichern W, Right(CStr(iDNr), 2)
        iDNr = iDNr + 1
    Next
    
    If iZeile <= iLetzte Then '... und der Rest  
        Set W = Workbooks.Add
        W.Activate
        With W.Worksheets(1)
            j = 1
            Do While iZeile <= iLetzte
                .Cells(j, 1) = aZeilen(iZeile)
                iZeile = iZeile + 1
                j = j + 1
            Loop
        End With
        AufteilenUndSpeichern W, Right(CStr(iDNr), 2)
    End If
Else
    MsgBox QUELLE & "\" & ASCNAME & " nicht gefunden!", vbCritical  
End If
MsgBox "Gesamtlaufzeit: " & Timer - x  
End Sub

Sub AufteilenUndSpeichern(WB As Workbook, sNummer As String)
'Spalte A mit eingelesener Textzeile mittels "Text in Spalten" aufteilen  
WB.Worksheets(1).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _  
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True

WB.SaveAs ZIEL & "\" & XLSNAME & sNummer & ".xls" 'Datei speichern ...  
WB.Close '... und schließen.  
End Sub

80010108 2147549448 RPC_E_DISCONNECTED: The object invoked has disconnected from its clients.

Const QUELLE = "D:\Test"  
Const ASCNAME = "KROS.ASC"  

Set fso = CreateObject("Scripting.FileSystemObject")  
aZeilen = Split(fso.OpenTextFile(QUELLE & "\" & ASCNAME, 1).ReadAll, vbCrLf)  
MsgBox "Eingelesen"  

Const QUELLE As String = "D:\Test"  
Const ASCNAME As String = "KROS.ASC"  
Const ZIEL As String = "D:\Test"  
Const XLSNAME As String = "Kros"  

Sub ImportSequ()
x = Timer

sQ = Dir(QUELLE & "\" & ASCNAME)  
If sQ <> "" Then  
    sZ = Dir(ZIEL & "\" & XLSNAME & "01.xls")  
    If sZ <> "" Then Kill ZIEL & "\" & XLSNAME & "??.xls" 'XLS-Dateien löschen  

    Open QUELLE & "\" & ASCNAME For Input As 1  
    iDNr = 101 'Zähler für Dateinamen (nur letzte 2 Stellen verwenden)  
    j = 1
    Dim W As Workbook
    Set W = Workbooks.Add
    W.Worksheets(1).Activate

    Do While Not EOF(1)
        If j <= 65536 Then
            Line Input #1, sZeile
            W.Worksheets(1).Cells(j, 1) = sZeile
            j = j + 1
        Else
            AufteilenUndSpeichern W, Right(CStr(iDNr), 2)
            iDNr = iDNr + 1
            j = 1
            Set W = Workbooks.Add
            W.Activate
        End If
    Loop

    AufteilenUndSpeichern W, Right(CStr(iDNr), 2) 'Die letzte Datei auch noch speichern ...  
    Close 1

Else
    MsgBox QUELLE & "\" & ASCNAME & " nicht gefunden!", vbCritical  
End If

MsgBox "Gesamtlaufzeit: " & Timer - x  
End Sub


Sub AufteilenUndSpeichern(WB As Workbook, sNummer As String)
'Spalte A mit eingelesener Textzeile mittels "Text in Spalten" aufteilen  
WB.Worksheets(1).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _  
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
WB.SaveAs ZIEL & "\" & XLSNAME & sNummer & ".xls" 'Datei speichern ...  
WB.Close '... und schließen.  
End Sub