VisualBasic Excel Formular mit Makros und Zellschutz, als Kopie ohne beides erstellen

Hi schnuff,

brauchst Du hier immer noch Hilfe? Ich hab mal ein Video gemacht :evillol:

Ich schick dir den Link als pn.

Gruesse
SOL

Edit: Hier ist noch der Code zur Loesung:

Code:
Public Sub Speichern()
Dim temp As String

With ThisWorkbook.Sheets(1)
    temp = .Cells(3, 1).Value & " " & Format(.Cells(2, 8).Value, "yyyymmdd")
    'noch schnell alle Leerzeichen durch Unterstriche ersetzen.'
    temp = Replace(temp, " ", "_", 1) & ".xlsx"
End With

NewFile (temp)

End Sub



Private Function NewFile(ByVal flnme As String)
Dim neu As Workbook
Set neu = Application.Workbooks.Add

Dim pfad As String

pfad = "c:\sol\" 'muss auf den richtigen Pfad angepasst werden

ThisWorkbook.Sheets(1).Range("A:I").Copy

With neu.Sheets(1).Range("A1")
    .PasteSpecial xlPasteAll 'wir kopieren erst alles
    .PasteSpecial xlPasteValues 'und dann nochmal die Values drueber
    .PasteSpecial xlPasteColumnWidths
    .Select
End With

neu.SaveAs pfad & flnme

neu.Close False
Set neu = Nothing

MsgBox "Datei wurde unter " & pfad & flnme & " gespeichert.", vbInformation
End Function
 
Zuletzt bearbeitet:
Hi SOL,

ich habe dein Video erhalten. Es ist einfach fantastisch erklärt. Ich habe jetzt gleich noch einen schulischen Termin.
Ich melde mich morgen dazu. Für deine Hilfestellung im Voraus schon einmal vielen, vielen Dank.

LG
schnuff
Ergänzung ()

Hi SOL,

ich habe deinen Code entsprechend eingearbeitet. Funktioniert gut und liefert das, was ich benötige.
Jedoch müssten wir ein paar kleine Anpassungen vornehmen.

1. Das kopierte sheet ist vom Format nicht identisch, hätte es gerne gestreckter auf dem DIN A 4 Blatt.
(siehe Anhang) Evtl. einzelene Zeilen verbreitern, aber das geht so glaube ich nicht.
2. Ich benötige die Kopfzeile aus dem Original in die Kopie.
3. Speichern unter Nachame+1.Vorname (also Lüdenscheidt Willi_20161203
4. Das Original sollte nach dem Speichern der Kopie wieder leer dargestellt sein.
5. Makro etwas langsam, aber das ist Nebenschauplatz.

Puuh, the never ending story.

VG
schnuff
Anhang anzeigen Willi + Maria Lüdenscheidt_161203.xlsx
 
Du willst es also nur ausdrucken? Welche Excel Version benutzt ihr? Evtl. reicht's wenn man einfach n PDF erzeugt. Was meinst Du mit Makro ist langsam? Versuchst Du das auf ein Netzlaufwerk zu speichern?
 
Nein, ich benötige es als .xlsx, Hintergrund ist, dass manchmal ein Kind das Essen ausfallen lässt (Krankheit, Praktikum etc.) und dann die erstellte Rechnung überarbeitet werden muss. Deswegen sollte auch die Formatierung ähnlich aussehen. Die Formeln lasse ich jetzt auch drin. (Version Excel 2013)
Mit dem langsamen Makro ist überschaubar. Ich lege die Datei in der Schule auf das Netzlaufwerk.
Hättest du mir vlt. noch Lösungsansätze zu Punkt 2,3,4.

LG
schnuff
 
Also ich tippe mal darauf, dass das Speichern im Netzlaufwerk das Makro ausbremst. Bei bei uns in der Firma hat das auch immer etwas gedauert :-)

Was den Rest angeht, mach ich mal ganz schnell:

2: Als was ist das Logo eingefuegt? Als Bild? Dann muessen wir wahrscheinlich den Code erweitern und das Bild explizit mit "umziehen"

3: Ich denke dafuer kannst Du meine "Namen Vertauschen" Routine herauskramen und einsetzten. Evtl. muss die noch etwas erweitert werden um nur den 1. Vornamen auszuspucken. Schau mal ob Du es hinbekommst.

4: Dafuer baust Du Dir am Besten eine Sub welche einen festgelegten Bereich saeubert. Sowas kommt immer gut.

Code:
Public Sub SauberMachen()

Range(xyz).ClearContents

End Sub

Das funktioniert so natuerlich noch nicht, aber Du bekommst eine Idee worauf ich hinaus will.

Welches Fach unterrichtest Du, wenn ich mal fragen darf?
 
Hi SOL,

zu deiner Frage was ich unterrichte! Wir sind ein Sonderpädagogisches Förderzentrum im Ganztagesbereich mit Mittagessen und Hausaufgabenbetreuung. Hier unterrichte ich Sport und div. Wahlfächer, sowie Grundlagen in der EDV. (Excel, Word, Power Point). Im Nachmittagsbereich betreue ich Freizeitaktivitäten wie Mountainbike, Klettern, Fussball. Des Weiteren bin ich Administrator in EDV Angelegenheiten für 45 Lehrer. Bei meinem jetzigen Projekt (Rechnungstool Mittagessen) gehörst du schon fast zur Familie.
Punkt 4 habe ich erledigt. Bei Pkt. 2 + 3 und einfügen der Kopfzeile aus dem Original wäre ich für Lösungsansätze dankbar.

VG
schnuff
 
Hey schnuff, sorry das ich jetzt erst schreibe. War heute etwas beschäftigt :-)

Nicht schlecht, Admin für 45 Leute ist sicherlich eine große Herausforderung. Nicht jeder klickt nur dahin wo er/sie hin klicken soll. Ich habe einige Office-Anwendungen für kleinere Teams geschrieben und immer wenn man denkt da kann nichts schief gehen, schafft es einer auf den ersten Versuch. :evillol:

Um der Familie weiter auszuhelfen, habe ich meine Namentauschen Funktion nochmal rausgesucht. Sie ist in ihrer ursprünglichen Form tatsächlich nicht für unser Vorhaben geeignet. Ich hoffe Du hast sie so eingebaut wie ich es damals vorgeschlagen hatte. Ich bin ein Freund von Modularität und würde diese Funktion jetzt einfach etwas erweitern und wiederverwenden.

Und zwar geben wir ihr noch eine optionale Variable mit auf den Weg welche wir dann in einem Select Case Scenario auswerten. Also, einfach die Funktion NamenTauschen in Deinem Code wie folgt abändern.

Code:
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(0) & trenn & tempArray(UBound(tempArray, 1))
    Case Else
        tempName = ""
End Select

NamenTauschen = tempName
End Function

Wenn Du es richtig machst, bleibt Dein restlicher Code davon unberührt. Du kannst allerdings jetzt Deinen String aus A3 übergeben und zusammen mit dem Trennzeichen " " und Mode 1 gibt die Funktion den ersten gefolgt vom letzten Namen wider.

So, jetzt zum Rest. Ich denke die Zeilenhöhe muss manuell angepasst werden. Sowas wie:
Code:
Rows(1).Height = 100

Und das Bilchen (Logo) einzeln kopiert werden. Sowas wie:
Code:
ThisWorkbook.Sheets(xyz).Shapes("Picture 3").Copy
neu.Sheets(1).Range("F1").PasteSpecial xlPasteAll
Den genauen Namen bekommst Du wenn Du auf das Logo klickst oben links in der Ecke.

Viel Spass beim probieren, wenn's nicht läuft, gib Bescheid.

Over and out, Martin
 
Hallo SOL,

spät aber der schnuff meldet sich. Die Schule und die anstehenden Weihnachtsfeiern sind in vollem Gange.
Ich habe soweit alles eingestellt und es läuft. Jedoch das speichern (Nametauschen)(Nachname+1.Vorname+Rechnungsdatum), da bekomme ich die Lampe nicht zum leuchten. Kannst du mir deine 1. Version mit der jetzigen neuen Änderung integriert, nochmals zukommen lassen, dass würde mir
sehr hilfreich sein.

VG
schnuff
 
Oh, habe natuerlich vergessen zu erwaehnen wie Du das Ganze anwendest :-)

Der angepasste Code steht in meinem letzten Post, zumindest fuer die Funktion vom letzten Mal. Jetzt hast Du in Deiner neuen "Speichern" Routine irgendwo die Stelle wo Du auf Zelle A3 zugreifst, um Dir den Namen fuer den Dateinamen zu "holen". Irgendwas mit Temp = Cells(3,1), oder so.

Was Du jetzt noch machen musst, ist diesen Wert aus Zelle A3 durch die Funktion NamenTauschen laufen zu lassen und zwar im Modus 1. Also temp = NamenTauschen(Zelle A3, 1). Wenn Du das ",1" weg laesst, funktioniert die Funktion wie vor der Anpassung.

Ich hoffe das war halbwegs vestaendlich, bin ein schlechter Lehrer :evillol:
 
Hallo SOL,

der letzte Schritt/Weg ist der schwerste. Ich bringe den Namentauschen Code nicht zum Laufen.
Im Anhang sende ich dir den kompletten Code, der auf meinem Speichern Button liegt. Schau doch bitte einmal darüber und ergänze den Namentauschen Code an der richtigen Position.
Vielen Dank im Voraus.

VG
schnuff
_____________________________________
' Speichern Button auf Sheet Rechnung

Sub Dateispeichernunter()

Dim temp As String
With ThisWorkbook.Sheets("Rechnung")

temp = .Cells(3, 1).Value & " " & Format(.Cells(2, 8).Value, "yymmdd")
temp = Replace(temp, " ", "_", 1) & ".xlsx"


End With

NewFile (temp)

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).Range("A1")
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteColumnWidths

ThisWorkbook.Sheets("rechnung").Shapes("Grafik 4").Copy

neu.Sheets(1).Range("H1").PasteSpecial xlPasteAll

neu.Sheets(1).Rows(1).RowHeight = 80
neu.Sheets(1).Rows(11).RowHeight = 66
neu.Sheets(1).Rows(7).RowHeight = 28
neu.Sheets(1).Rows(8).RowHeight = 28
neu.Sheets(1).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")
.PasteSpecial xlPasteAll
.PasteSpecial xlPasteColumnWidths


End With


' Kopfzeile kopieren und einfügen


' Druckbereich festlegen
Range("A1:I38").Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$I$38"
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""

End With

' Zoomfaktor einstellen
ActiveSheet.PageSetup.PrintArea = "$A$1:$I$38"
With ActiveSheet.PageSetup
.Zoom = 85
.PrintErrors = xlPrintErrorsDisplayed

End With


neu.SaveAs Pfad & flnme

neu.Close Fales
Set neu = Nothing

MsgBox " Datei wurde unter " & Pfad & flnme & " gespeichert.", vbInformation

' Felder leeren
' Blattschutz deaktivieren
ActiveWorkbook.Sheets("Rechnung").Unprotect "xxxx"
' Dokument leeren button. Position: Tabellenblatt Rechnungen
' Felder mit Essensangabe und Anschrift leeren.

Range("A13:H25,A3,A4,A6").Select
Selection.ClearContents
ActiveWorkbook.Save
Range("A1").Select

' Blattschutz aktivieren:
ActiveWorkbook.Sheets("Rechnung").Protect "xxxx"


End Function
 
Hi schnuff, jetzt ist es soweit. Hatte noch ein paar Fehlerchen in meinem Code. Hab ganz ueberlesen das Du den Nachnamen zuerst brauchst :-)

Ich habe gleich noch ein paar Anpassungen an Deinem Code vorgenommen und ihn ein wenig aufgedroesselt.

Code:
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

Einfach alle Subs und Funktionen ersetzen, dann sollte es laufen.

Viel Glueck
Martin
 
Hi SOL,

danke für deinen Einsatz und die große Mühe. Jedoch läuft der Code nicht durch!

Fehlermeldung: Laufzeitzeitfehler 9 (Index außerhalb des gültigen Bereichs)

(siehe Anhang)
Fehler.PNG
 
mmhhhh, das passiert wenn in A3 kein Name drin steht, oder aus einem anderen Grund ein leerer String an die Funktion uebergeben wird. Das ist ein Fehler welchen man am Besten noch mit abfaengt.

Am einfachsten indem Du die Zeile

Code:
If nme = "" Then mode = 2
vor
Code:
tempArray = Split(nme, trenn)
In der NamenTauschen Funktion einfuegst.
 
Hi SOL,

es ist vollbracht. Mein Rechnungstool ist fertig. Dein Code läuft, liefert und zeigt das an, was benötigt wird.
Für deinen unermüdllichen Einsatz fallen mir nur diese Worte ein:
Ein kleines Wort -
Danke! -
findet zu dir,
weil grosse Worte für alles,
was ich sagen möchte,
zu klein sind dafür.

Eine gute Zeit für dich, ein frohes Weihnachtsfest, hab es gut.

LG
schnuff
 
Super, das freut mich. Dir auch ein schoenes Weihnachtsfest und wenn Du mal wieder was brauchst, weisst Du wo Du mich findest :evillol:
 
Zurück
Oben