Hier das Makro, ist vom Arbeitskollegen
04.12.2025 18:27:48
werner
Guten Abend Ralf,
das Makro ist von einem Arbeitskollegen, der natürlich besser ist als ich und wir wollen zusammen aus unserem Rechenformular xlsm
versuchen eine eRechnung zu erstellen.
Public Sub Export_eRechnung()
On Error GoTo ErrHandler
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("RechnungW")
' --- Kundendaten ---
Dim KundenName As String: KundenName = Trim("" & ws.Range("O15").value)
Dim RgNr As String: RgNr = Trim("" & ws.Range("H24").value)
Dim RgDatumRaw As Variant: RgDatumRaw = ws.Range("H29").value
Dim RgDatum As Date
If IsDate(RgDatumRaw) Then RgDatum = CDate(RgDatumRaw)
Dim KundenNr As String: KundenNr = Trim("" & ws.Range("O11").value)
Dim KundenStr As String: KundenStr = Trim("" & ws.Range("O18").value)
Dim KundenPLZ As String: KundenPLZ = Trim("" & ws.Range("O20").value)
Dim KundenStadt As String: KundenStadt = Trim("" & ws.Range("O21").value)
Dim KundenKontakt As String: KundenKontakt = Trim("" & ws.Range("O17").value)
Dim KundenEmail As String: KundenEmail = Trim("" & ws.Range("O24").value)
Dim KundenLand As String: KundenLand = Trim("" & ws.Range("O22").value)
Dim MwStSatz As String: MwStSatz = Trim("" & ws.Range("H1").value)
Dim Waehrung As String: Waehrung = Trim("" & ws.Range("P1").value)
If Waehrung = "" Then Waehrung = "EUR"
Dim Netto As Double: Netto = SafeVal(ws.Range("P38").value)
Dim MwSt As Double: MwSt = SafeVal(ws.Range("P39").value)
Dim Brutto As Double: Brutto = SafeVal(ws.Range("P40").value)
' --- Lieferant / Firma ---
Dim sName As String: sName = Trim("" & ws.Range("W20").value)
Dim sContact As String: sContact = Trim("" & ws.Range("W21").value)
Dim sEmail As String: sEmail = Trim("" & ws.Range("W22").value)
Dim sStr As String: sStr = Trim("" & ws.Range("W23").value)
Dim sCity As String: sCity = Trim("" & ws.Range("W24").value)
Dim sPLZ As String: sPLZ = Trim("" & ws.Range("W25").value)
Dim sCountry As String: sCountry = Trim("" & ws.Range("W26").value)
Dim sUSt As String: sUSt = Trim("" & ws.Range("W27").value)
Dim sIBAN As String: sIBAN = Trim("" & ws.Range("W29").value)
Dim sKonto As String: sKonto = Trim("" & ws.Range("W30").value)
Dim sBIC As String: sBIC = Trim("" & ws.Range("W31").value)
' --- TypeCode bestimmen (380 Standard, 381 bei negativ) ---
' Dim TypeCode As String: TypeCode = "380"
' --- TypeCode bestimmen (380 / 381) ---
Dim Gesamtbetrag As Double
Gesamtbetrag = WorksheetFunction.Sum( _
Union( _
Range("F27:F50"), _
Range("F91:F115"), _
Range("F155:F179"), _
Range("F220:F282"), _
Range("F283:F346"), _
Range("F347:F410")))
Dim TypeCode As String
If Gesamtbetrag 0 Or Brutto 0 Then
TypeCode = "381" ' Gutschrift
Else
TypeCode = "380" ' Rechnung
End If
' --- Dateiname ---
Dim rawFileName As String
rawFileName = "Rechnung Rg.-Nr." & RgNr & ".xml"
Dim Desktop As String: Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Dim tmpPath As String: tmpPath = Desktop & "\__temp_xrechnung.xml"
Dim FinalPath As String: FinalPath = Desktop & "\" & SanitizeFileName_Minimal(rawFileName)
Dim Datum102 As String: Datum102 = Format(RgDatum, "yyyymmdd")
' --- XML erstellen ---
Dim xml As String
xml = "" & vbCrLf
xml = xml & "
"xmlns:rsm=""urn:un:unece:uncefact:data:standard:CrossIndustryInvoice:100"" " & _
"xmlns:ram=""urn:un:unece:uncefact:data:standard:ReusableAggregateBusinessInformationEntity:100"" " & _
"xmlns:udt=""urn:un:unece:uncefact:data:standard:UnqualifiedDataType:100"">" & vbCrLf
' ExchangedDocument
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(RgNr) & "" & vbCrLf
xml = xml & " " & TypeCode & "" & vbCrLf
xml = xml & " " & Datum102 & "" & vbCrLf
xml = xml & " Rechnung" & vbCrLf
xml = xml & " " & vbCrLf
' SupplyChainTradeTransaction
xml = xml & " " & vbCrLf
' --- Seller ---
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(sName) & "" & vbCrLf
If sContact > "" Then xml = xml & " " & EscapeXML(sContact) & "" & vbCrLf
If sEmail > "" Then xml = xml & " " & EscapeXML(sEmail) & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(sPLZ) & "" & vbCrLf
xml = xml & " " & EscapeXML(sStr) & "" & vbCrLf
xml = xml & " " & EscapeXML(sCity) & "" & vbCrLf
xml = xml & " " & EscapeXML(sCountry) & "" & vbCrLf
xml = xml & " " & vbCrLf
If sUSt > "" Then
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(sUSt) & "" & vbCrLf
xml = xml & " " & vbCrLf
End If
If sIBAN > "" Then
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(sIBAN) & "" & vbCrLf
If sKonto > "" Then xml = xml & " " & EscapeXML(sKonto) & "" & vbCrLf
If sBIC > "" Then xml = xml & " " & EscapeXML(sBIC) & "" & vbCrLf
xml = xml & " " & vbCrLf
End If
xml = xml & " " & vbCrLf
' --- Buyer ---
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(KundenName) & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(KundenPLZ) & "" & vbCrLf
xml = xml & " " & EscapeXML(KundenStr) & "" & vbCrLf
xml = xml & " " & EscapeXML(KundenStadt) & "" & vbCrLf
xml = xml & " " & EscapeXML(KundenLand) & "" & vbCrLf
xml = xml & " " & vbCrLf
If KundenKontakt > "" Then xml = xml & " " & EscapeXML(KundenKontakt) & "" & vbCrLf
If KundenEmail > "" Then xml = xml & " " & EscapeXML(KundenEmail) & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
' --- Delivery ---
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & Datum102 & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
' --- Settlement ---
xml = xml & " " & vbCrLf
xml = xml & " " & EscapeXML(Waehrung) & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & Replace(Format(Netto, "0.00"), ",", ".") & "" & vbCrLf
xml = xml & " " & Replace(Format(MwSt, "0.00"), ",", ".") & "" & vbCrLf
xml = xml & " " & Replace(Format(Brutto, "0.00"), ",", ".") & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " Zahlbar innerhalb 14 Tagen" & vbCrLf
xml = xml & " " & vbCrLf
' --- Lines: alle Zeilen bis 6 Seiten ---
' Dim LineRanges As Variant: LineRanges = Array(27 To 91, 92 To 155, 156 To 219, 220 To 282, 283 To 346, 347 To 410)
Dim LineRanges As Variant
LineRanges = Array( _
Array(27, 50), _
Array(91, 115), _
Array(155, 179), _
Array(220, 282), _
Array(283, 346), _
Array(347, 410))
Dim i As Long, r As Long, lineCount As Long: lineCount = 0
Dim anyNegative As Boolean: anyNegative = False
Dim idx As Long
For idx = LBound(LineRanges) To UBound(LineRanges)
Dim rng As Variant: rng = LineRanges(idx)
For r = rng(0) To rng(1)
Dim besch As String: besch = Trim("" & ws.Cells(r, 2).value)
Dim menge As Double: menge = SafeVal(ws.Cells(r, 3).value)
Dim preis As Double: preis = SafeVal(ws.Cells(r, 4).value)
Dim linGes As Double: linGes = SafeVal(ws.Cells(r, 5).value)
If Len(besch) > 0 And Abs(menge) > 0.0000001 Then
lineCount = lineCount + 1
If linGes 0 Or preis 0 Or menge 0 Then anyNegative = True
xml = xml & " " & vbCrLf
xml = xml & " " & lineCount & "" & vbCrLf
xml = xml & " " & EscapeXML(besch) & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & Replace(Format(preis, "0.00"), ",", ".") & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & Replace(Format(menge, "0.##"), ",", ".") & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " VAT" & vbCrLf
xml = xml & " S" & vbCrLf
xml = xml & " " & EscapeXML(MwStSatz) & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & Replace(Format(linGes, "0.00"), ",", ".") & "" & vbCrLf
xml = xml & " " & vbCrLf
xml = xml & " " & vbCrLf
End If
Next r
Next idx
' --- TypeCode anpassen falls negativ ---
If anyNegative Or Brutto 0 Then
TypeCode = "381"
xml = Replace(xml, "380", "381", , 1)
End If
xml = xml & " " & vbCrLf
xml = xml & "" & vbCrLf
' --- XML speichern UTF-8 ohne BOM ---
Dim stm As Object, bin As Object, out As Object
Set stm = CreateObject("ADODB.Stream")
stm.Type = 2
stm.Charset = "UTF-8"
stm.Open
stm.WriteText xml
stm.SaveToFile tmpPath, 2
stm.Close
' BOM entfernen
Set bin = CreateObject("ADODB.Stream")
bin.Type = 1
bin.Open
bin.LoadFromFile tmpPath
Dim totalBytes As Long: totalBytes = bin.Size
Dim startOffset As Long: startOffset = 0
If totalBytes >= 3 Then
bin.Position = 0
Dim hdr: hdr = bin.Read(3)
If AscB(MidB(hdr, 1, 1)) = &HEF And AscB(MidB(hdr, 2, 1)) = &HBB And AscB(MidB(hdr, 3, 1)) = &HBF Then
startOffset = 3
End If
End If
Set out = CreateObject("ADODB.Stream")
out.Type = 1
out.Open
bin.Position = startOffset
out.Write bin.Read
out.SaveToFile FinalPath, 2
bin.Close: Set bin = Nothing
out.Close: Set out = Nothing
On Error Resume Next: Kill tmpPath
MsgBox "XRechnung erfolgreich exportiert:" & vbCrLf & FinalPath, vbInformation, "Fertig"
Exit Sub
ErrHandler:
MsgBox "Fehler im Export: " & Err.Description, vbCritical, "Fehler"
End Sub
' ---------------------------
' --- Helper-Funktionen ---
' ---------------------------
Private Function EscapeXML(ByVal s As String) As String
If Len(Trim(s)) = 0 Then EscapeXML = "": Exit Function
s = Replace(s, "&", "&")
s = Replace(s, "", "<")
s = Replace(s, ">", ">")
s = Replace(s, """", """)
s = Replace(s, "'", "'")
EscapeXML = s
End Function
Private Function SafeVal(ByVal v As Variant) As Double
If IsNumeric(v) Then
SafeVal = CDbl(v)
Else
SafeVal = 0
End If
End Function
Private Function SanitizeFileName_Minimal(ByVal s As String) As String
Dim out As String, i As Long, ch As String
out = ""
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If InStr(1, "/\:*?"">|", ch) = 0 Then out = out & ch
Next i
If out = "" Then out = "Rechnung.xml"
SanitizeFileName_Minimal = out
End Function