Sub Dateispeichernunter()
Dim Dateiname As String
With ThisWorkbook.Sheets("Rechnung")
'Dateinamen zusammensetzen aus A3, H4 und H2
'Wobei A3 durch die Funktion NamenTauschen laeuft NamenTauschen(Name, Trennzeichen, Modus)
Dateiname = NamenTauschen(.Cells(3, 1).Value, " ", 1) & " " & .Cells(4, 8).Value & " " & Format(.Cells(2, 8).Value, "yymmdd")
'Leerzeichen durch Unterstriche ersetzen
Dateiname = Replace(Dateiname, " ", "_", 1) & ".xlsx"
End With
'Function call NewFile wo wir Dateiname uebergeben
NewFile Dateiname
'Rechnungsbereich leeren Worksheet uebergeben
FelderLeeren ThisWorkbook.Sheets("Rechnung")
End Sub
Private Function NewFile(ByVal flnme As String)
Dim neu As Workbook
Set neu = Application.Workbooks.Add
Dim Pfad As String
Pfad = "C:\Users\s\Desktop\Rechnungstool DonBo Original\"
'Daten aus Rechnung kopieren
ThisWorkbook.Sheets("Rechnung").Range("A1:I38").Copy
With neu.Sheets(1)
'Daten einfuegen
.Range("A1").PasteSpecial xlPasteAll
.Range("A1").PasteSpecial xlPasteColumnWidths
'Rechnungsdatum festsetzen
.Range("H2").Value = Format(.Range("H2").Value, "dd.mm.yyyy")
'Logo kopieren
ThisWorkbook.Sheets("rechnung").Shapes("Grafik 4").Copy
'Logo einfuegen
.Range("H1").PasteSpecial xlPasteAll
'Zeilenhoehe setzen
.Rows(1).RowHeight = 80
.Rows(11).RowHeight = 66
.Rows(7).RowHeight = 28
.Rows(8).RowHeight = 28
.Rows(28).RowHeight = 63
End With
' Daten aus Blatt oBP kopieren
ThisWorkbook.Sheets("Vorlage oBP").Range("J9:K27").Copy
With neu.Sheets(1).Range("J9:K27")
'Daten einfuegen
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteColumnWidths
End With
With neu.Sheets(1).PageSetup
'Druckbereich festlegen
.PrintArea = "$A$1:$I$38"
.PrintTitleRows = ""
.PrintTitleColumns = ""
'Zoomfaktor einstellen
.Zoom = 85
.PrintErrors = xlPrintErrorsDisplayed
End With
'Datei speichern
neu.SaveAs Pfad & flnme
'Datei schliessen ohne Meldung
neu.Close False
'Speicher freigeben
Set neu = Nothing
'Message box ueber Erfolg ausgeben
MsgBox " Datei wurde unter " & Pfad & flnme & " gespeichert.", vbInformation
End Function
'Funktion vertauscht Namen in der Variable nme
Public Function NamenTauschen(ByVal nme As String, ByVal trenn As String, Optional ByVal mode As Byte) As String
Dim tempArray As Variant
Dim tempName As String
Dim x
tempArray = Split(nme, trenn)
Select Case mode
Case 0
For x = 1 To UBound(tempArray, 1)
tempName = tempName & tempArray(x) & trenn
Next x
tempName = tempName & tempArray(0)
Case 1
tempName = tempArray(UBound(tempArray, 1)) & trenn & tempArray(0)
Case Else
tempName = ""
End Select
NamenTauschen = tempName
End Function
Public Sub FelderLeeren(ByRef blatt As Worksheet)
With blatt
.Select
' Felder leeren
' Blattschutz deaktivieren
.Unprotect "xxxx"
' Dokument leeren button. Position: Tabellenblatt Rechnungen
' Felder mit Essensangabe und Anschrift leeren.
.Range("A13:H40,A3,A4,A6").ClearContents
.Range("A1").Select
' Blattschutz aktivieren:
.Protect "xxxx"
ActiveWorkbook.Save
End With
End Sub
