Sieht die CSV-Datei so aus?
Bei meinem Mandanten waren es immer drei Zeilen.
Hier mein Konvertierungstool (natürlich wieder VBSript):
Option Explicit
Dim objExcel
Dim objNetwork
Dim sUser
Dim objFSO
Dim RunDir
Dim sCheckValue
Dim cSumNetto
Dim cSumUSt
Dim cSumBrutto
Set objNetwork = CreateObject("WScript.Network")
sUser=objNetwork.UserName
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
MsgBox "Öffnen Sie bitte das Rechnungsausgangsbuch in Excel und fahren Sie fort.",vbYesNo , "Konvertieren Excel-RAB"
Set objExcel = GetObject(,"Excel.Application")
objExcel.Visible = True
'Excel-Makro
Dim shtSource
Dim shtTarget
Dim iRow , iRowTarget
Dim dDate
Dim iColKredit
Dim sTmp, sTmp1
Dim blnStop
Dim iGS
Const xlSortOnValues =0
Const xlAscending =1
Const xlSortNormal =0
const xlEdgeTop =8
Const xlEdgeBottom =9
Const xlContinuous =1
Const xlRight =-4152
Const xlDouble=-4119
Const xlThick =4
Const xlThin =2
Const xlContext=-5002
Const xlUnderlineStyleNone=-4142
Const xlThemeFontNone=0
Dim FiBu_Lauf
FiBu_Lauf = InputBox("Geben Sie den FiBu-Monat ein (MM/JJJJ)!","Abfrage FiBu-Monat")
objExcel.Application.DisplayAlerts = False
If SheetEx("FiBu") = True Then
objExcel.Sheets("FiBu").Delete
End If
Set shtSource = objExcel.ActiveSheet
shtSource.Columns("A:A").RowHeight = 15
shtSource.cells(1,1).select
objExcel.Sheets.Add
Set shtTarget = objExcel.ActiveWorkbook.Sheets(1)
shtTarget.Name = "FiBu"
iRowTarget = 1
With shtTarget
.Cells(iRowTarget, 1).Value = "RGID"
.Cells(iRowTarget, 2).Value = "BelegNr1"
.Cells(iRowTarget, 3).Value = "GKtoNr"
.Cells(iRowTarget, 4).Value = "Kundenbezeichnung"
.Cells(iRowTarget, 5).Value = "Datum"
.Cells(iRowTarget, 6).Value = "Netto"
.Cells(iRowTarget, 7).Value = "USt"
.Cells(iRowTarget, 8).Value = "Betrag"
.Cells(iRowTarget, 9).Value = "Kto"
.Columns("E").NumberFormat = "m/d/yyyy"
.Columns("D").NumberFormat = "#,##0.00"
.Columns("F").NumberFormat = "#,##0.00"
.Columns("G").NumberFormat = "#,##0.00"
.Columns("H").NumberFormat = "#,##0.00"
With .Range(.Cells(1, 1), .Cells(1, 9)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
cSumBrutto=0
cSumNetto=0
cSumUSt=0
Const cRGNr=3
Const cKonto=4
Const cKdnr=5
Const cStorno=7
Const cDatum=8
Const cText=9
Const cNetto=10
Const cUSt=11
Const cBrutto=12
Const cVorgang=13
cSumNetto=shtSource.Cells(2, cNetto).Value
cSumUSt=shtSource.Cells(2, cUSt).Value
cSumBrutto=shtSource.Cells(2, cBrutto).Value
iRow =2
blnStop=False
iGS=-1
Dim lColBrutto
Dim Kunden
Dim sKundenText
If objFSO.FileExists(objExcel.ActiveWorkbook.Path & "\Kunden.csv") then objfso.DeleteFile(objExcel.ActiveWorkbook.Path & "\Kunden.csv")
Set Kunden = objFSO.OpenTextFile(objExcel.ActiveWorkbook.Path & "\Kunden.csv",2,True)
shtSource.Activate
Do While blnStop = False
If shtSource.Cells(iRow, 3).Text<>"" then
With shtTarget
iRowTarget = iRowTarget + 1
.Cells(iRowTarget, 2).Value = shtSource.Cells(iRow, cRGNr).Value
.Cells(iRowTarget, 3).Value = shtSource.Cells(iRow, cKdnr).Value
.Cells(iRowTarget, 4).Value = shtSource.Cells(iRow, cText).Value
'Kundenliste
sKundenText= shtSource.Cells(iRow, cKdnr).Value & ";" & shtSource.Cells(iRow, cText).Value
Kunden.Writeline sKundenText
.Cells(iRowTarget, 5).Value = CDate(shtSource.Cells(iRow, cDatum).Value)
.Cells(iRowTarget, 6).Value = shtSource.Cells(iRow, cNetto).Value*iGS
.Cells(iRowTarget, 7).Value = shtSource.Cells(iRow, cUSt).Value*iGS
.Cells(iRowTarget, 8).Value = shtSource.Cells(iRow, cBrutto).Value*iGS
'Kontierungsvorbelegung
If CCur(shtSource.Cells(iRow, cUSt).Value)=0 Then
If InStr(shtSource.Cells(iRow, cKonto),"4401",1)> 0 Then
.Cells(iRowTarget, 1).Value= "4401 - Abschlag"
.Cells(iRowTarget, 9).Value = "3250"
Else
.Cells(iRowTarget, 1).Value= shtSource.Cells(iRow, cKonto).Value & " - Rechnung"
.Cells(iRowTarget, 9).Value = "4337"
End If
Else
If InStr(shtSource.Cells(iRow, cKonto),"4401",1)> 0 Then
.Cells(iRowTarget, 1).Value= "4401 - Abschlag"
.Cells(iRowTarget, 9).Value = "3272"
Else
.Cells(iRowTarget, 1).Value= shtSource.Cells(iRow, cKonto).Value & " - Rechnung"
.Cells(iRowTarget, 9).Value = "4400"
End If
End if
End With
End If
iRow=iRow+1
blnStop = (shtSource.Cells(iRow, 1).Value="")
Loop
With shtTarget
.Columns("A").EntireColumn.AutoFit
.Columns("D").EntireColumn.AutoFit
End With
Kunden.close
shtTarget.Activate
objExcel.Application.DisplayAlerts = False
Dim sFile
Const xlCSV = 6
Const xlOpenXMLWorkbook=51
objExcel.Application.StatusBar = sMessage & " / RAB wird unter gespeichtert '" & sFile & "' gespeichert!"
sFile =objExcel.ActiveWorkbook.Path & "\RAB " & Left(FiBu_Lauf,2) & "-" & Right(FiBu_Lauf,4)
objExcel.ActiveWorkbook.SaveAs sFile,xlOpenXMLWorkbook '51
Function SheetEx(strNam)
On Error Resume Next
SheetEx = objExcel.Sheets(strNam).Index > 0
End Function
'WScript.Echo GetExcelCol(50,False)
Public Function GetExcelCol(lIdx, bInitialCall)
If (bInitialCall) Then lIdx = lIdx + 1
If (lIdx = 0) Then Exit Function
GetExcelCol = GetExcelCol((lIdx - 1) \ 26, False) + Chr(65 + (lIdx - 1) Mod 26)
End Function
'WScript.Echo GetIndexOfExcelCol("AX", 0,False)
Public Function GetIndexOfExcelCol(ByVal strCol, ByVal slevel, ByVal bInitialCall)
Dim tInitialCall
If (CInt(slevel) = Len(strCol)) Then Exit Function
If CBool(bInitialCall) = True Then
tInitialCall=-1
Else
tInitialCall=0
End if
GetIndexOfExcelCol = GetIndexOfExcelCol(strCol,CInt(slevel) + 1, False) + ((Asc(Mid(strCol, Len(strCol) - CInt(slevel), 1)) - 65) + 1) * 26 ^ CInt(slevel) + CLng(tInitialCall)
End Function
Und das Ergebnis sieht dann so aus:
Es wird auch automatisch eine Kundenliste erstellt, damit man die Kontenbeschriftung mit importieren kann (ASCII-Format).
Den Code einfach kopieren und in eine Textdatei kopieren und als *.vbs speichern. Anschließend einfach die Excel-Datei öffnen und das Tool per Doppelklick starten.
Im Pfad der VBS-Datei wird alles gespeichert.
Sollte klappen, ansonsten einfach hier melden.
Gruß Achilleus
