Hallo snb,
den ganzen Code?
Der ist aber sehr lang.
Zunächst werden die Listeneinträge (insg. eben 120) in einem Formular der Reihe nach abgearbeitet.
Bei jedem Eintrag wird dann der folgende Code aufgerufen:
Public Sub RechnungAlle()
'On Error GoTo Fehler
Dim WordObj As Object
Dim strPfad As String
Dim Datum As Date
Dim strAdress As String
Dim Text As String
Dim Aufseher As String
Dim eMailMA As String
Dim EMailJa As String
Dim ReNr As String
Dim AngNr As String
Dim CDateiName As String
Dim wks_Eing As Worksheet
Dim wks_Mit As Worksheet
Dim wks_ReGes As Worksheet
Dim wks_ReEinz As Worksheet
Dim wks_EinÜb As Worksheet
Dim wks_EinAuftr As Worksheet
Dim wks_Obj As Worksheet
Dim wks_Adr As Worksheet
Dim wks_ReBuch As Worksheet
Dim wks_Pausch As Worksheet
Dim Netto As Double
Dim MwSt As Double
Dim Brutto As Double
Dim lzAdr As Integer
Dim lzReGes As Integer
Dim lzEingabe As Integer
Dim lzEinÜb As Integer
Dim lzEinAuftr As Integer
Dim lzObj As Integer 'letzte Zeile in Objekte
Dim lzReBuch As Integer
Dim lzPausch As Integer
Dim ReBeschr As String
Dim i As Integer
Dim Dif As Integer 'Anzahl der zu übertragene Zeilen
Dim Einziehung As String
Dim IBAN As String
Dim BIC As String
Dim Bank As String
Dim Mandat As String
Dim Gläubiger As String
Dim TextBank As String
Dim Objekt As String
Dim Arr(1, 2)
Dim Einzel()
Set wks_Adr = ThisWorkbook.Worksheets("Adressen")
Set wks_Obj = ThisWorkbook.Worksheets("Objekte")
Set wks_Eing = ThisWorkbook.Worksheets("Eingabeformular")
Set wks_Mit = ThisWorkbook.Worksheets("Mitarbeiter")
Set wks_ReGes = ThisWorkbook.Worksheets("RechnungGesamt")
Set wks_ReEinz = ThisWorkbook.Worksheets("RechnungenEinzelposten")
Set wks_EinÜb = ThisWorkbook.Worksheets("EinnahmenÜberschuss")
Set wks_EinAuftr = ThisWorkbook.Worksheets("Einzelaufträge")
Set wks_ReBuch = ThisWorkbook.Worksheets("RechnungsBuch")
Set wks_Pausch = ThisWorkbook.Worksheets("PauschalAufträge")
lzAdr = wks_Adr.Cells(Rows.Count, 1).End(xlUp).Row
lzReGes = wks_ReGes.Cells(Rows.Count, 2).End(xlUp).Row + 1
lzReEin = wks_ReEinz.Cells(Rows.Count, 1).End(xlUp).Row
lzEingabe = wks_Eing.Cells(Rows.Count, 1).End(xlUp).Row
lzEinÜb = wks_EinÜb.Cells(Rows.Count, 2).End(xlUp).Row + 1
lzEinAuftr = wks_EinAuftr.Cells(Rows.Count, 2).End(xlUp).Row
lzObj = wks_Obj.Cells(Rows.Count, 1).End(xlUp).Row
lzReBuch = wks_ReBuch.Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
Objekt = wks_Eing.Cells(3, 2)
AngNr = wks_Eing.Cells(4, 2)
ReNr = wks_Eing.Cells(6, 2)
For i = 2 To lzObj
If wks_Obj.Cells(i, 2) = Objekt Then
KdNr = wks_Obj.Cells(i, 6)
ObjNr = wks_Obj.Cells(i, 1)
End If
Next i
For i = 2 To lzAdr
With wks_Adr
If KdNr = wks_Adr.Cells(i, 1) Then
KdNr = .Cells(i, 1)
Vertreter = .Cells(i, 18) & " " & .Cells(i, 2) & " " & .Cells(i, 3)
Adresse = .Cells(i, 4)
Ort = .Cells(i, 5) & " " & .Cells(i, 6)
eMailKunde = .Cells(i, 9)
Einziehung = .Cells(i, 10)
IBAN = .Cells(i, 11)
BIC = .Cells(i, 12)
Bank = .Cells(i, 13)
Mandat = .Cells(i, 14)
Gläubiger = .Cells(i, 15)
EMailJa = .Cells(i, 16)
Firmenbez = .Cells(i, 17)
End If
End With
Next i
Datum = Date
'Die Rechnungsnummer
ReNr = wks_Eing.Cells(6, 2) 'Ist die Rechnungsnummer
Ablagejahr = Year(Date)
Ablageordner = ThisWorkbook.Path & "\Hausservice Rechnungen\Rechnungen " & Ablagejahr
If Dir(Ablageordner, vbDirectory) = "" Then
MkDir (Ablageordner)
MsgBox "Ordner für " & Ablagejahr & " wurde angelegt!"
End If
'Die Speicheradresse und der Speichername mit Objektkennung, Rechnungsnummer und Datum
CDateiName = Ablageordner & "\" & " Rechnung Nr. " & ReNr & " " & Datum & ".PDF"
ReBeschr = wks_Eing.Cells(3, 2) & " Rechnung " & ReNr
wks_Eing.Activate
If Range("B6") = "" Then
MsgBox "Uups, du hast noch keine Rechnungsnummer eingetragen", , "Achtung"
Exit Sub
Else
For i = 2 To lzReGes
If wks_ReGes.Cells(i, 2) = wks_Eing.Range("B6") Then
MsgBox "Die Nummer " & wks_Eing.Range("B6") & " ist bereits vorhanden", , "Neue Nummer"
Exit Sub
End If
Next i
With wks_Eing
lz = .Cells(Rows.Count, 1).End(xlUp).Row
Netto = Format(Excel.WorksheetFunction.Sum(.Range(Cells(10, 5), Cells(lz, 5))), "#,##0.00 ")
MwSt = Format(Excel.WorksheetFunction.Product(Excel.WorksheetFunction.Sum(.Range(Cells(10, 5), _
Cells(lz, 5))), 0.19), "#,##0.00 ")
Brutto = Format(Netto + MwSt, "#,##0.00 ")
Arr(0, 0) = "Gesamtnetto"
Arr(0, 1) = "MwSt. 19%"
Arr(0, 2) = "Gesamtsumme"
Arr(1, 0) = Netto
Arr(1, 1) = MwSt
Arr(1, 2) = Brutto
End With
If Einziehung = "Ja" Then
TextBank = "Den Rechnungsbetrag in Höhe von " & Brutto & " EUR ziehen wir mit der SEPA- _
Lastschrift zum Mandat " & Mandat & _
" zu der Gläubiger ID-Nr " & Gläubiger & " von ihrem Konto " & IBAN & " bei der " & _
Bank & " (BIC: " & BIC & ") ein."
Else
TextBank = "Bitte überweisen Sie den Betrag auf eines unserer untenstehenden Konten."
End If
On Error Resume Next
'Set WordObj = GetObject(, "Word.Application")
If WordObj Is Nothing Then
Set WordObj = CreateObject("Word.Application")
Else
End If
WordObj.Documents.Add (ThisWorkbook.Path & "\Hausservice Vorlagen\RechnungPauschal.docx")
WordObj.Visible = False
'Ab hier werden die einzelnen Zellen kopiert, und in die vorhandenen bookmards (Textmarken in _
Word) mit den entspr. Namen eingefügt:
WordObj.Activate
If WordObj.ActiveDocument.Bookmarks.Exists("Leistung") Then
WordObj.Selection.GoTo What:=-1, Name:="Leistung"
WordObj.Selection.Tables.Add Range:=WordObj.ActiveDocument.Bookmarks("Leistung").Range, _
NumRows:=lz - 3, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With WordObj.Selection.Tables(1)
' If .Style "Tabellenraster" Then
' .Style = "Tabellenraster"
' End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Else
MsgBox "Die Textmarke Leistung ist nicht vorhanden"
End If
k = 1
'Tabelle mit der entsprechenden Textmarke wurde gefunden, die gesamte Tabelle wird daraufhin _
als Range definiert
Set oTable = WordObj.ActiveDocument.Bookmarks("Leistung").Range.Tables(1)
With oTable 'WordObj.ActiveDocument.Tables(1)
For i = 10 To lz
.cell(k, 1) = wks_Eing.Cells(i, 1)
.cell(k, 2) = Format(wks_Eing.Cells(i, 5), "#,##0.00 ")
.cell(k, 2).Range.ParagraphFormat.Alignment = 2 '2 ist rechtsbündig
.Rows(k).SetHeight RowHeight:=15, HeightRule:=wdRowHeightAtLeast
.Rows(k).Select
k = k + 1
Next i
.Columns(2).SetWidth ColumnWidth:=220, RulerStyle:=wdAdjustNone
.cell(k + 1, 1) = Arr(0, 0)
.cell(k + 1, 1).Range.ParagraphFormat.Alignment = 2
.cell(k + 1, 2) = Format(Arr(1, 0), "#,##0.00 ")
.cell(k + 1, 2).Range.ParagraphFormat.Alignment = 2
.cell(k + 3, 1) = Arr(0, 1)
.cell(k + 3, 1).Range.ParagraphFormat.Alignment = 2
.cell(k + 3, 2) = Format(Arr(1, 1), "#,##0.00 ")
.cell(k + 3, 2).Range.ParagraphFormat.Alignment = 2
.cell(k + 5, 1) = Arr(0, 2)
.cell(k + 5, 1).Range.ParagraphFormat.Alignment = 2
.cell(k + 5, 1).Cells.Font.Bold = True
.cell(k + 5, 2) = Format(Arr(1, 2), "#,##0.00 ")
.cell(k + 5, 2).Range.ParagraphFormat.Alignment = 2
.cell(k + 5, 2).Cells.Font.Bold = True 'wdToggle
.cell(k + 5, 2).Cells.Font.Underline = wdUnderlineDouble
End With
wks_Eing.Range("A8:E8").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Leistung") Then
WordObj.ActiveDocument.Bookmarks("Leistung").Range = wks_Eing.Range("A8")
Else
MsgBox "Die Textmarke Leistung ist nicht vorhanden"
End If
'wks_Eing.Range("B6").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("AngNr") Then
WordObj.ActiveDocument.Bookmarks("AngNr").Range = ReNr
Else
MsgBox "Die Textmarke MarkeAngNr ist nicht vorhanden"
End If
ThisWorkbook.Sheets(wks_Eing).Range("F3").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Datum") Then
WordObj.ActiveDocument.Bookmarks("Datum").Range = wks_Eing.Range("F3").Value
Else
MsgBox "Die Textmarke MarkeDatum ist nicht vorhanden"
End If
'Firmenbezeichnung einfügen
If WordObj.ActiveDocument.Bookmarks.Exists("Firmenbez") Then
WordObj.ActiveDocument.Bookmarks("Firmenbez").Range = Firmenbez
Else
MsgBox "Die Textmarke Firmenbez ist nicht vorhanden"
End If
'ThisWorkbook.Sheets(wks_Eing).Range("B1").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Name") Then
WordObj.ActiveDocument.Bookmarks("Name").Range = Vertreter
Else
MsgBox "Die Textmarke Name ist nicht vorhanden"
End If
'ThisWorkbook.Sheets(wks_Eing).Range("B3").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Objekt") Then
WordObj.ActiveDocument.Bookmarks("Objekt").Range = Objekt
Else
MsgBox "Die Textmarke Objekt ist nicht vorhanden"
End If
'ThisWorkbook.Sheets(wks_Eing).Range("B4").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Adresse") Then
WordObj.ActiveDocument.Bookmarks("Adresse").Range = Adresse
Else
MsgBox "Die Textmarke Adresse ist nicht vorhanden"
End If
'ThisWorkbook.Sheets(wks_Eing).Range("B5").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Ort") Then
WordObj.ActiveDocument.Bookmarks("Ort").Range = Ort
Else
MsgBox "Die Textmarke Ort ist nicht vorhanden"
End If
'"Bezahloption" ist die Einfügemarke
If WordObj.ActiveDocument.Bookmarks.Exists("Bezahloption") Then
WordObj.ActiveDocument.Bookmarks("Bezahloption").Range = TextBank
Else
MsgBox "Die Textmarke Bezahloption ist nicht vorhanden"
End If
' With WordObj
' .ActiveDocument.SaveAs Filename:=CDateiName 'Als Word Dokument speichern
'End With
'If MsgBox("Ändere ggf. das Word-Dokument ab und klicke danach hier OK", vbOKCancel, " _
Durchsicht des Dokuments") = vbOK Then
'Als Pdf speichern
With WordObj
With .ActiveDocument
.ExportAsFixedFormat OutputFileName:=CDateiName, _
ExportFormat:=17, Openafterexport:=False, OptimizeFor:=0, _
Range:=0, From:=1, To:=1, _
Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=0, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
If EMailJa = "" Then
'.PrintOut
End If
.Close SaveChanges:=False
End With
End With
WordObj.ActiveDocument.Close SaveChanges:=False
Rem Email erstellen
If EMailJa = "Ja" Then
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .HTMLBody
.To = eMailKunde
'.CC = Aufseher & "; " & eMailMA
'.BCC = strAddress
.subject = "Rechnung" ' Betreff
.HTMLBody = "Sehr _
geehrte Damen und Herren,
" & _
"anbei finden Sie die Rechnung zu ihrem Objekt.
" & _
"Mit freundlichen Grüßen
" & _
"Ihr Team
" '& olOldBody Body. "
" = _
Zeilenumbruchanweisung"
.Attachments.Add CDateiName 'Datei anhängen
End With
End If
'WordObj.Quit SaveChanges:=wdDoNotSaveChanges
Set WordObj = Nothing
'wks_ReGes.Visible = True
'Eintrag in Gesamtrechnung
With wks_ReGes
.Cells(lzReGes, 2) = wks_Eing.Cells(6, 2)
.Cells(lzReGes, 4) = KdNr
.Cells(lzReGes, 5) = wks_Eing.Cells(3, 6)
.Cells(lzReGes, 6) = Netto
.Cells(lzReGes, 7) = MwSt
.Cells(lzReGes, 8) = Brutto
End With
'Eintrag in EinnahmenÜberschuss
With wks_EinÜb
.Cells(lzEinÜb, 2) = ReBeschr
.Cells(lzEinÜb, 3) = "Umsatzst.pfl. 19%"
.Cells(lzEinÜb, 6) = Brutto
End With
'Eintrag in RechnungEinzelposten
lzEingabe = wks_Eing.Cells(Rows.Count, 1).End(xlUp).Row
Dif = lzEingabe - 9
k = 10
ReDim Einzel(Dif, 9)
For i = 0 To Dif - 1
Einzel(i, 0) = ReNr
Einzel(i, 1) = KdNr
Einzel(i, 2) = Objekt
Einzel(i, 3) = wks_Eing.Cells(k, 1)
Einzel(i, 4) = wks_Eing.Cells(k, 2)
Einzel(i, 5) = wks_Eing.Cells(k, 3)
Einzel(i, 6) = wks_Eing.Cells(k, 5)
Einzel(i, 7) = wks_Eing.Cells(k, 6)
Einzel(i, 8) = wks_Eing.Cells(k, 7)
Einzel(i, 9) = wks_Eing.Cells(k, 8)
k = k + 1
Next i
wks_ReEinz.Range(wks_ReEinz.Cells(lzReEin + 1, 1), wks_ReEinz.Cells(lzReEin + Dif, 10)) = _
Einzel
With wks_EinAuftr
For i = 2 To lzEinAuftr
If .Cells(i, 1) = AngNr Then
Rows(i).Delete
i = i - 1
End If
Next i
End With
lzEingabe = wks_Eing.Cells(Rows.Count, 1).End(xlUp).Row
With wks_Eing
.Activate
.Range("A10:G" & lzEingabe + 5).SpecialCells(xlCellTypeConstants) = ""
.Cells(lzEingabe + 6, 5).Copy
.Range(Cells(10, 5), Cells(lzEingabe + 5, 5)).PasteSpecial xlPasteAll
.Range("F4").ClearContents
.Range("B4:C4").ClearContents
.Range("B3").ClearContents
.Range("A8:E8") = ""
.Range("B6").Value = .Range("B6").Value + 1
End With
Application.DisplayAlerts = True
End If
End Sub
Falls du auch noch eine Lösung dafür hast, wie in der Word-Tabelle die letzte Zeile Fett und doppelt unterstrichen gemacht werden kann wäre das echt super.
In meinem Code oben funktionierts nämlich nicht.
Danke für deine Hilfe
Gruß Oisse