Hallo Leute,
ich habe die Prüfung auf Leerzeilen robuster gestaltet. Anscheinend kam es bei einigen Anwender zu einer Fehlermeldung, weil am Ende des exportierten DATEV-Vorlaufs ein nicht druckbares Zeichen angefügt wurde. Nach einer Internetrecherche handelt es sich um ein sog. SUB-Kennzeichen für die Markierung des Dateiendes. Woher und warum das nur bei einige auftaucht, ist mir rätselhaft. Es soll uns aber auch nicht weiter interessieren.
Hinzugekommen ist noch eine Abfrage, ob das Festschreibungskennzeichen aufgehoben werden soll, sollte es sich um ein bereits festgeschriebenen Vorlauf handeln.
Wer noch das Leistungsdatum für die Aufteilung berücksichtigen möchte, der verwende bitte die Separate_DATEVExt.vbs aus dem anderen Beitrag.
Hier nun die überarbeitete Fassung:
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const DATEVBelegdatum = 9
Const DATEVFibuVon = 14
Const DATEVFibuBis = 15
Const DATEVFestschreibung=113
Dim fs
Dim sFileIn, f
Dim sPathOutput
Dim i, z, q
Dim sFileOut
Dim sLine
Dim sTemp, tArray
Dim sYear, iMonth
Dim sOutputFile
Dim ReadFibu
Dim blnResetFK
Set fs = createobject("Scripting.FileSystemObject")
If WScript.Arguments.length> 0 Then
sFileIn = WScript.Arguments(0)
Else
If sFileIn="" Then sFileIn=ChooseFile()
If sFileIn="" Then WScript.Quit
End If
sPathOutput=GetPathName(sFileIn)
sFileOut = GetFileNameWithOutExtension(sFileIn)
Dim sChooseExport: sChooseExport=InputBox("Bitte wählen Sie die Exportart aus." & vbNewLine & vbNewLine & " => m = Monat" & vbNewLine & " => q = Quartal","Vorlauf trennen","m")
If sChooseExport="" Then WScript.Quit
If sChooseExport="q" Then
ReDim sOutputFile(3)
Else
ReDim sOutputFile(11)
End If
Set f = fs.OpenTextFile(sFileIn,ForReading)
Select Case LCase(sChooseExport)
Case "m" 'je Monat
For i = 0 To 11
Set sOutputFile(i)=fs.OpenTextFile(fs.BuildPath(sPathOutput, sFileOut &"_" & FormatExt((i+1),2) & ".csv") ,ForWriting,True,0)
Next
'First Step
'Write Header, erste Zeile Umwandlung Vorlaufdatum
For z = 1 To 2
sLine=f.Readline
If z = 1 Then 'Fibu-Vorlaufdatum
tArray = Split(sLine,";")
If tArray(20)="1" Then 'Feschreibekennzeichen Header
If MsgBox("Der Vorlauf wurde bereits festgeschrieben." & vbNewLine & "Möchten Sie für den späteren Import das Festschreibekennzeichen aufheben?",vbYesNo+vbQuestion+vbDefaultButton2,"Aufhebung Feschreibung")=vbYes Then
blnResetFK=True
tArray(20)="0"
End If
End If
sYear = Left(tArray(DATEVFibuVon),4)
For i = 0 To 11
tArray(DATEVFibuVon)=sYear & FormatExt((i+1),2) & "01" 'Monatsanfang
If i=11 Then
tArray(DATEVFibuBis)=sYear & "1231" 'Dezember
Else
tArray(DATEVFibuBis)=sYear & FormatExt((i+1),2) & Day(DateSerial(sYear,(i+2),0)) 'Monats => 0.03.2020 => 29.02.2020
End If
For q=LBound(tArray) To UBound(tArray)
sTemp = sTemp & tArray(q) & ";"
Next
sTemp = Left(sTemp,Len(sTemp)-1)
sOutputFile(i).writeline sTemp
sTemp=""
Next
Else
For i = 0 To 11
sOutputFile(i).writeline sLine
Next
End If
Next
'End First Step
'Second Step
'Lese Fibu-Daten und verteile auf Einzevorläufe
Do Until f.AtEndOfStream
sLine = f.ReadLine
tArray=Split(sLine,";")
If UBound(tArray)>0 Then
If blnResetFK = True Then
sLine=""
tArray(DATEVFestschreibung)="0"
For i=0 To UBound(tArray)
sLine=sLine & tArray(i) & ";"
Next
sLine=Left(sLine,Len(sLine)-1)
End If
iMonth=Right(tArray(DATEVBelegdatum),2)
sOutputFile(CInt(iMonth)-1).writeline sLine
End If
Loop
'End Second Step
'Last Step
'Schließe alle offenen Dateien
For i = 0 To 11
sOutputFile(i).close
If GetNumberOfLines(fs.BuildPath(sPathOutput, sFileOut &"_" & FormatExt((i+1),2) & ".csv")) <= 3 Then fs.DeleteFile(fs.BuildPath(sPathOutput, sFileOut &"_" & FormatExt((i+1),2) & ".csv"))
Next
MsgBox "Alle Buchungssätze wurden monatsweise in einzelne Vorläufe verteilt. Die Dateien haben den Zusatz *_MM erhalten und können jetzt importiert werden.",48,"Konvert DATEV-Fibu"
Case "q" 'je Quartal
For i = 0 To 3
Set sOutputFile(i)=fs.OpenTextFile(fs.BuildPath(sPathOutput, sFileOut &"_" & RomanNumber((i+1)) & ".csv") ,ForWriting,True,0)
Next
'First Step
'Write Header, erste Zeile Umwandlung Vorlaufdatum
For z = 1 To 2
sLine=f.Readline
If z = 1 Then 'Fibu-Vorlaufdatum
tArray = Split(sLine,";")
If tArray(20)="1" Then 'Feschreibekennzeichen Header
If MsgBox("Der Vorlauf wurde bereits festgeschrieben." & vbNewLine & "Möchten Sie für den späteren Import das Festschreibekennzeichen aufheben?",vbYesNo+vbQuestion+vbDefaultButton2,"Aufhebung Feschreibung")=vbYes Then
blnResetFK=True
tArray(20)="0"
End If
End If
sYear = Left(tArray(DATEVFibuVon),4)
For i = 0 To 3
tArray(DATEVFibuVon)=sYear & FormatExt(((i+1)*3)-2,2) & "01" 'Anfang Quartal
If i=3 Then
tArray(DATEVFibuBis)=sYear & "1231" 'Dezember
Else
tArray(DATEVFibuBis)=sYear & FormatExt(((i+1)*3),2) & Day(DateSerial(sYear,((i+1)*3)+1,0)) 'Ende Quartal => 0.03.2020 => 28.02.2020
End If
For q=LBound(tArray) To UBound(tArray)
sTemp = sTemp & tArray(q) & ";"
Next
sTemp = Left(sTemp,Len(sTemp)-1)
sOutputFile(i).writeline sTemp
sTemp=""
Next
Else
For i = 0 To 3
sOutputFile(i).writeline sLine
Next
End If
Next
'End First Step
'Second Step
'Lese Fibu-Daten und verteile auf Einzevorläufe
Do Until f.AtEndOfStream
sLine = f.ReadLine
tArray=Split(sLine,";")
If UBound(tArray)>0 Then
If blnResetFK = True Then
sLine=""
tArray(DATEVFestschreibung)="0"
For i=0 To UBound(tArray)
sLine=sLine & tArray(i) & ";"
Next
sLine=Left(sLine,Len(sLine)-1)
End If
iMonth=Right(tArray(DATEVBelegdatum),2)
Select Case True
Case iMonth >= 1 And iMonth <= 3
sOutputFile(0).writeline sLine
Case iMonth >= 4 And iMonth <= 6
sOutputFile(1).writeline sLine
Case iMonth >= 7 And iMonth <= 9
sOutputFile(2).writeline sLine
Case iMonth >= 10 And iMonth <= 12
sOutputFile(3).writeline sLine
End Select
End If
Loop
'End Second Step
'Last Step
'Schließe alle offenen Dateien
For i = 0 To 3
sOutputFile(i).close
If GetNumberOfLines(fs.BuildPath(sPathOutput, sFileOut &"_" & RomanNumber((i+1)) & ".csv")) <= 3 Then fs.DeleteFile(fs.BuildPath(sPathOutput, sFileOut &"_" & RomanNumber((i+1)) & ".csv"))
Next
MsgBox "Alle Buchungssätze wurden quartalsweise in einzelne Vorläufe verteilt. Die Dateien haben den Zusatz *_QQ erhalten und können jetzt importiert werden.",48,"Konvert DATEV-Fibu"
Case Else
MsgBox "Sie haben eine falsche Auswahl getroffen. Erlaubt ist nur je Monat (m) oder je Quartal (q)." & vbNewLine & vbNewLine & "Bitte wiederholen Sie den Vorgang.",48,"Falsche Auswahl Exportart"
WScript.Quit
End Select
'Hilfsfunktionen
'---------------
Function GetPathName(sFilePath)
sFilePath = Replace(sFilePath, "/" , "\")
GetPathName = Left(sFilePath, InStrRev(sFilePath, "\"))
End Function
Function GetFileName(sFilePath)
GetFileName = fs.GetFileName(sFilePath)
End Function
Function GetFileNameWithOutExtension(sFilePath)
GetFileNameWithOutExtension = fs.GetBaseName(sFilePath)
End Function
Function FormatExt(Zahl,Anzahl)
FormatExt= Right(String(Anzahl, "0") & zahl,Anzahl)
End Function
Function GetNumberOfLines(strFile)
Dim ts
Dim myArray
Dim z
Set ts = fs.OpenTextFile(strFile)
myArray=Split(ts.ReadAll,vbNewLine)
For z=UBound(myArray) To 0 Step -1
If Len(myArray(z))>2 Then
GetNumberOfLines=(z+1)
Exit For
End If
Next
End Function
Function FormatExt(Zahl,Anzahl)
FormatExt= Right(String(Anzahl, "0") & zahl,Anzahl)
End Function
Function RomanNumber(Number)
Dim Result
Select Case Number
Case 1 : Result="I"
Case 2 : Result="II"
Case 3 : Result="III"
Case 4 : Result="IV"
End Select
RomanNumber=Result
End Function
Function ChooseFile()
Set oExec=CreateObject("WScript.Shell").Exec( "mshta.exe ""about:" & "<" & "input type=file id=FILE>" & "<" & "script>FILE.click();new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);" & "<" & "/script>""" )
Tst = oExec.StdOut.ReadAll
Tst = Replace( Tst, vbCRLF, "" )
ChooseFile= Tst
End Function
Den Code einfach kopieren und in eine Textdatei einfügen. Anschließend die Datei umbenennen in z. B. SeparateDATEVFibu.vbs, wichtig ist die Extension "VBS".
Ich übernehme keine Verantwortung für Schäden am Datenbestand oder System. Es werden von mir keine Änderungen am System vorgenommen. Anspruch auf Support besteht nicht, stehe aber gerne für Probleme und Fragen hier im Forum zur Verfügung.
Gruß Achilleus
