Vielen Dank für das Script. Wir haben einige Anpassungen betreffs der Belegfelder vorgenommen: _____________________________ Option Explicit Dim objFSO Set objFSO = CreateObject("Scripting.FileSystemObject") If objFSO.FileExists("N:\DATEN\Mandant\#####\Paypal\Paypal.csv") Then objFSO.DeleteFile("N:\DATEN\Mandant\#####\Paypal\Paypal.csv") End If On Error Resume Next '############### Step 1 -> CSV in ANSI konvertieren Private Const adReadAll = -1 Private Const adSaveCreateOverWrite = 2 Private Const adTypeBinary = 1 Private Const adTypeText = 2 Private Const adWriteChar = 0 UTF8toANSI WScript.Arguments(0), WScript.Arguments(0) '############### Step 2 -> Über Excel in Spalten konvertieren Dim objExcel Dim objWkb Dim objWks Set objExcel = GetObject(,"Excel.Application") If err.number<>0 Then Err.Clear Set objExcel = CreateObject("Excel.Application") objExcel.Workbooks.Add End if Set objWks = objExcel.Workbooks(1).Sheets(1) objExcel.Visible = True Dim objReadFile Set objReadFile =objFSO.OpenTextFile(WScript.Arguments(0), 1) Dim colBank(34) 'Spaltendefinition siehe DATEV-Schnittstelle (Feld 1 - 34) Dim curGeb Dim sTemp Dim MyResult Dim i, lCol, lRow Do Until objReadFile.AtEndOfStream sTemp=objReadFile.Readline sTemp = Replace (sTemp,""",""",";") sTemp = Replace (sTemp,"""","") MyResult = Split(sTemp,";") lRow=lRow+1 For i = 0 To UBound(MyResult)-1 lCol=i+1 Select Case lCol Case 6,7,8,9,15,16 'WScript.Echo MyResult(i) If IsNumeric(MyResult(i))=False Then objWks.cells(lRow,lCol).Value=MyResult(i) Else objWks.cells(lRow,lCol).Value=CCur(MyResult(i)) End If Case Else objWks.cells(lRow,lCol).Value=MyResult(i) End Select Next Loop objWks.columns("J:J").Insert, -4152 lRow = 1 Const sQuote = """" With objWks 'Spaltenüberschriften der neuen Excel-Datei .cells(lRow,1).value="BelegDatum" .cells(lRow,6).value="Betrag" .cells(lRow,10).value="Buchungstext" End With Dim MyFile Set MyFile = objFSO.OpenTextFile("N:\DATEN\Mandant\#####\Paypal\Paypal.csv", 2, True) Const xlCellTypeLastCell=11 For i = 2 To objWks.usedrange.specialcells(xlCellTypeLastCell).row lRow=lRow+1 If objWks.cells(lRow,5).value ="EUR" Then 'nur EUR-Beträge werden berücksichtigt If objWks.cells(lRow,13).value<>"" Then 'Buchungstext mit/ohne Transaktionscode (nur für den Fall 'das der Bankenimport nicht 'richtig funktioniert) = redundant objWks.cells(lRow,10).value = objWks.cells(lRow,11).value & " / " & objWks.cells(lRow,13).value Else objWks.cells(lRow,10).value = objWks.cells(lRow,11).value End If curGeb = curGeb + CCur(objWks.cells(lRow,7)) 'Aufsummierung PayPal-Gebühren colBank(1) = sQuote & "89999999" & sQuote 'Blz colBank(2) = sQuote & "123456" & sQuote 'KtoNr colBank(5) = objWks.cells(lRow,1) 'Datum Valuta colBank(6) = objWks.cells(lRow,1) 'Buchungsdatum colBank(7) = FormatNumber(objWks.cells(lRow,6),2) 'Umsatz colBank(8) = objWks.cells(lRow,13) 'Auftraggebername 1 (Name) colBank(12) = objWks.cells(lRow,11) 'Verwendungszweck 1 (Transaktionscode) colBank(13) = objWks.cells(lRow,18) 'Verwendungszweck 2 (Rechnungsnummer) colBank(14) = objWks.cells(lRow,12) 'Verwendungszweck 3 (EMail) colBank(17) = "EUR" 'Währung colBank(18) = objWks.cells(lRow,4) 'Buchungstext (Beschreibung) colBank(19) = objWks.cells(lRow,14) 'Verwendungszweck 6 (Bank) colBank(29) = FormatNumber(objWks.cells(lRow,7),2) 'Gebühren sTemp="" For lCol=1 To UBound(colBank) sTemp = sTemp & colBank(lCol) & ";" Next sTemp = Left(sTemp,Len(sTemp)-1) 'letztes Semikolon löschen (überschüssig) MyFile.Writeline sTemp End If Next 'zuletzt noch als letzte Bankbewegung die summierten PayPal-Gebühren sTemp="" sTemp = sTemp & sQuote & "89999999" & sQuote & ";" 'Blz sTemp = sTemp & sQuote & "123456" & sQuote & ";" 'KtoNr sTemp = sTemp & ";" 'Auszug sTemp = sTemp & ";" 'Datum Auszug sTemp = sTemp & DateSerial(Year(objWks.cells(lRow,1)),Month(objWks.cells(lRow,1))+1,0) & ";" 'Datum Valuta sTemp = sTemp & DateSerial(Year(objWks.cells(lRow,1)),Month(objWks.cells(lRow,1))+1,0) & ";" 'Datum Buchung sTemp = sTemp & FormatNumber(curGeb,2) & ";" 'Umsatz sTemp = sTemp & "PayPal" & ";" 'Auftraggebername 1 sTemp = sTemp & "" & ";" 'Auftraggebername 2 sTemp = sTemp & "" & ";" 'BLZ Auftraggeber sTemp = sTemp & "" & ";" 'Kto Auftraggeber sTemp = sTemp & "PayPal-Gebühren" & ";" 'Verwendungszweck 1 sTemp = sTemp & "" & ";" 'Verwendungszweck 2 MyFile.Writeline sTemp MyFile.Close MsgBox "PayPal-Buchungen können jetzt importiert werden.",,"Export PayPal" Private Sub UTF8toANSI(ByVal UTF8FName, ByVal ANSIFName) Dim strText With CreateObject("ADODB.Stream") .Open .Type = adTypeBinary .LoadFromFile UTF8FName .Type = adTypeText .Charset = "utf-8" strText = .ReadText() .Position = 0 .SetEOS .Charset = "x-ansi" 'Use current ANSI codepage. .WriteText strText, adWriteChar .SaveToFile ANSIFName, adSaveCreateOverWrite .Close End With End Sub
... Mehr anzeigen