Genial. Heute mal eine längere Mittagspause gemacht - und schon ist die Lösung da. Finde es super , dass Sie sich so für die Gemeinschaft einbringen. Dem ist nichts hinzuzufügen! Hier noch mal der komplette Code (mit Pfad "S:\" und Ersetzung von ";" durch ","): Option Explicit Dim objExcel Dim shtSource Dim shtTarget Dim iRow, q, iCol Dim sValue(114) 'lt. Feldbeschreibung Buchungsstapel Dim sTemp On Error Resume Next Set objExcel = GetObject(,"Excel.Application") If err.number<>0 Then Err.Clear Set objExcel = CreateObject("Excel.Application") End if objExcel.Visible = True On Error Goto 0 Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") Dim cDatum Dim cBelegfeld1 Dim cBelegfeld2 Dim cBuchungstext Dim cUmsatzSoll Dim cUmsatzHaben Dim cKOST1 Dim EB_Datum Dim sTmp Dim GGKto, iLenKonto Dim sKtoSplitter 'Pfade bitte anpassen 'muss nicht gelöscht werden, da beim Import in DATEV diese Datei gelöscht werden kann. 'Damit ist es jetzt möglich, mehrere Konten mit EB-Wert vorzutragen (s. ForAppending) 'If objFSO.FileExists("S:\EB_Werte.csv") then objfso.DeleteFile("S:\EB_Werte.csv") Set shtSource = objExcel.ActiveSheet EB_Datum = InputBox( "Geben Sie bitte das EB-Datum in Form dd.mm.jjjj ein.","EB-Datum","01.01." & Year(Now())) If EB_Datum="" then '[´....] Tu was wenn leer Else EB_Datum =FormatExt(Day(EB_Datum),1) & FormatExt(Month(EB_Datum),2) If InStr(1,shtSource.cells(1,1),"Abschlusskonto",1)<>0 Then 'Export aus Abschluss sKtoSplitter="Abschlusskonto" ElseIf InStr(1,shtSource.cells(1,1),"Kontoblatt",1)<>0 Then 'Export aus Kontoblatt sKtoSplitter="Kontoblatt" ElseIf InStr(1,shtSource.cells(1,1),"Arbeitskonto",1)<>0 Then 'Export aus Arbeitskonto sKtoSplitter="Arbeitskonto" Else MsgBox "Der Kontoexport konnte nicht erkannt werden. Es werden nur Arbeitskonto, normales Konto u. Abschlusskonto unterstützt.",vbCritical, "Exportfehler" WScript.Quit End If 'sTmp=Split(shtSource.cells(1,1),"Arbeitskonto",0,1) sTmp = Split(shtSource.cells(1,1),sKtoSplitter,2,1) 'Auslesen des GGKto. GGKto =GetEBKonto(sTmp(1)) 'letzte Trennung falls mehrere '-' vorhanden iLenKonto = LenKonto(GGKto) Const xlCellTypeLastCell=11 'Auslesen der Feldreihenfolge For iCol=1 To shtSource.usedrange.specialcells(xlCellTypeLastCell).Column Select Case shtSource.cells(2,iCol).Text Case "Datum": cDatum=iCol Case "Belegfeld1": cBelegfeld1=iCol Case "Belegfeld2": cBelegfeld2=iCol Case "Buchungstext": cBuchungstext=iCol Case "Umsatz Soll": cUmsatzSoll=iCol Case "Umsatz Haben": cUmsatzHaben=iCol Case "KOST1": cKOST1=iCol End Select Next Dim MyFile Const ForReading = 1, ForWriting = 2, ForAppending = 8 If objFSO.FileExists("S:\EB_Werte.csv") = False then 'Pfade bitte anpassen 'Spaltenüberschriften For iCol = 1 To 114 sTemp = sTemp & "Spalte " & iCol & ";" Next End If Set MyFile = objFSO.OpenTextFile("S:\EB_Werte.csv", ForAppending, True) 'Pfade bitte anpassen If Len(sTemp)>0 Then MyFile.Writeline sTemp For iRow = 3 To shtSource.usedrange.specialcells(xlCellTypeLastCell).row If shtSource.cells(iRow,cUmsatzSoll) <>"" Then sValue(1) = shtSource.cells(iRow,cUmsatzSoll) sValue(2)="H" Else sValue(1) = shtSource.cells(iRow,cUmsatzHaben) sValue(2)="S" End If sValue(7) = "9" & String(iLenKonto-1, "0") sValue(8) = Replace(GGKto," ","") sValue(10) = EB_Datum If Not IsEmpty(cBelegfeld1) Then sValue(11) = Trim(shtSource.cells(iRow,cBelegfeld1)) If Not IsEmpty(cBelegfeld2) Then sValue(12) = Trim(shtSource.cells(iRow,cBelegfeld2)) If Not IsEmpty(cBuchungstext) Then sValue(14) = Replace(Trim(shtSource.cells(iRow,cBuchungstext)),";",",") If Not IsEmpty(cKOST1) Then sValue(37) = Trim(shtSource.cells(iRow,cKOST1)) sValue(114) = 0 sTemp="" For q = 1 To 114 sTemp = sTemp & sValue(q) & ";" Next MyFile.Writeline sTemp Next MyFile.close MsgBox "Fibu-Werte stehen zur Verfügung." End if 'Hilfsfunktion Function FormatExt(Zahl,Anzahl) FormatExt= Right(String(Anzahl, "0") & zahl,Anzahl) End Function Function GetEBKonto(EBValue) GetEBKonto = Trim(Mid(EBValue, 3, InStr(3, EBValue, " - ", vbTextCompare) - 3)) End Function Function LenKonto(Konto) If Len(konto) > 4 Then LenKonto = 4 + Len(Right(Konto, Len(Konto) - InStr(1, Konto, " ", vbTextCompare))) Else LenKonto = 4 End If End Function Eine Kleinigkeit habe ich noch ergänzt: If objFSO.FileExists("S:\EB_Werte.csv") = False then 'Pfade bitte anpassen (Zumindest das habe ich hinbekommen ) Viele Grüße & ein schönes Wochenende.
... Mehr anzeigen