AW: Makroverknüpfung der Schaltflächen ändert sich
27.10.2009 09:18:00
Frank
Der Code für das Kopieren und Speichern der Ziel Arbeitsmappe. Hochladen ist wegen der Beschränkung auf 300 kB nicht möglich.
'Sicherung der Anwesenheitslisten
Sub Sicherung_Anwesenheit(M)
Antwort = ""
Dim AnwSave As String
Application.ScreenUpdating = False
On Error GoTo Fehler
Windows(WbSystem).Activate
Sheets("Stammdaten").Select
Auswahl = "Anwesenheit_Neu"
Beruf = Range("d42")
Nummer = Range("d41")
Monat = Range("a69")
Jahr = Range("d36")
Ejahr = Range("d44")
Ausbilder = InputBox("Bitte Ausbildernamen eingeben:", "Anwesenheit erstellen", Worksheets(" _
Data").Range("n30"))
If Ausbilder = "" Then
Antwort = "Ende"
Exit Sub
End If
Blattname = Beruf & "'" & Ejahr & " -" & Monat & "." & Jahr ' & " -" & Nummer
Text = "Bitte geben Sie einen Namen für die zu speichernde Anwesenheitsliste im Monat " & Chr$( _
13) & "- " & M & Chr$(13) & "ein"
If Ejahr = "xx" Then Text = Text & vbLf & vbLf & "Achtung: Die Gruppe ist nicht homogen, d.h. _
es sind Azubis unterschiedlicher Berufsgruppen oder Ausbildungsjahre darin. Es wird empfohlen getrennte Anwesenheitslisten zu erstellen!"
Blattname = InputBox(Text, "Blattname", Blattname)
If Blattname = "" Then
Antwort = "Ende"
Exit Sub
End If
Call Kontrolle_Blattname(Blattname)
If Antwort = "Ende" Then
Exit Sub
End If
Call ActivateOpen(WBAnwesenheit, FileAnwesenheit, True)
If Sheets.Count > 99 Then
MsgBox "Die maximale Blattanzahl von 100 ist erreicht." & Chr$(13) & "Bitte löschen Sie nicht _
benötigte Blätter in der Datei " & FileAnwesenheit & ".", vbOKOnly, "Blattanzahl überschritten"
Exit Sub
End If
Anzahl = Sheets.Count
For i = 1 To Sheets.Count
If UCase(Sheets(i).Name) = UCase(Blattname) Then
Antwort = MsgBox("Das Blatt existiert bereits!" & Chr$(13) & _
"- Drücken Sie JA zum überschreiben" & Chr$(13) & _
"- Drücken Sie NEIN um abzubrechen" & Chr$(13) & Chr$(13) & _
"Bei JA (Löschen) wird die vorhandene Anwesenheit überschrieben und die Einträge _
unwiederuflich gelöscht!", vbYesNo, "Anwesenheit")
If Antwort = vbNo Then
Antwort = "Ende"
Exit Sub
Else
If Sheets.Count = 1 Then
Set NeuesBlatt = Worksheets.Add
NeuesBlatt.Name = "Leerblatt"
End If
Worksheets(Blattname).Delete
If Sheets.Count = Anzahl Then
Call Zurück_zum_Hauptmenue
Exit Sub
End If
GoTo weiter:
End If
End If
Next i
For Each Name In ActiveWorkbook.Names
Name.Delete
Next Name
weiter:
Workbooks(WbSystem).Worksheets(Auswahl).Activate
Sheets(Auswahl).Copy before:=Workbooks(WBAnwesenheit).Sheets(1)
Call EntSperr(Auswahl)
Sheets(Auswahl).Name = Blattname
'Einzelwerte sichern
With Workbooks(WBAnwesenheit).Worksheets(Blattname)
.Range("I4:AN4") = Workbooks(WbSystem).Worksheets(Auswahl).Range("I4:AN4").Value
.Range("AA1:AG1") = Workbooks(WbSystem).Worksheets(Auswahl).Range("AA1:AG1").Value
.Range("AI1:AN1") = Workbooks(WbSystem).Worksheets(Auswahl).Range("AI1:AN1").Value
.Range("B6:AM26") = Workbooks(WbSystem).Worksheets(Auswahl).Range("B6:AM26").Value
.Range("ab1") = Blattname
.Range("z1") = Ejahr
.Range("ai1") = Ausbilder
End With
Range("i6").Select
Ende:
Workbooks(WbSystem).Worksheets(Auswahl).Activate
Call Sperr(Auswahl)
Exit Sub
Fehler:
Call ErrorHandler("Modul: Sicherung_Anwesenheit - File: " & FileASicherung & "Parameter: " & M)
End Sub