Hi, warum der Aufwand. Sowas gibt es schon fertig:
http://wiki-de.genealogy.net/Vorlagen_zur_Erfassung_genealogischer_...
Musst nur suchen.

Guten Morgen Como!

Diese Seite kenne ich schon. Es geht mir nicht darum die Blätter mit der Hand auszufüllen, sondernd die Daten in einer Datei abzuspeichern.
Das abspeichern einzelner Blätter soll dazu dienen, den lebenden Familienmitgliedern ihr persönliches Blatt zu schicken.

Internette Grüsse
Mick

Hallo Mick,
habe deine .Datei nach deinen Wünschen angepasst
Speicherort überprüfen: M:\BackUp_Eigene Dateien\Ahnenforschung

Gruß
fedjo

Hallo fedjo!

Vielen, vielen Dank erstmal für Deine Mühe!

Darf ich noch einen Wunsch äußern? Auf der Startseite mit der eingebauten Sortierfunktion "Enthaltene Blätter", wäre es hier möglich die Tabellenblätter "Startseite" und "Vorlage" beim sortieren auszuschließen damit sie auf der Startseite nicht erscheinen?

Mit dem Speicherbutton auf den Familienblättern erhalte ich den Hinweis
"Laufzeitfehler '1004':

Der programmatische Zugriff auf das Visual Basic-Projekt ist nicht sicher"

Könnte ich hier mit der Speicherfunktion, direkt in einen bestimmten Ordner speichern?

Internette Grüsse
Mick

Huch ganz vergessen... zum Wunsch Speichern. Direkt in einen bestimmten Ordner mit dem Tabellenblattnamen.

Internette Grüsse
Mick

Hallo fedjo!

Ich glaube so langsam nerv ich?

Irgend etwas mache ich wohl falsch!
Über den Button "Neues Familienblatt" rufe ich die Meldung "Familiennamen eingeben" auf.
Trage die Familie "FamiliennameA_FamiliennameB" ein.
Fülle das Familienblatt aus.
Gehe auf Speichern und bekomme den Laufzeitfehler angezeigt. Der Ordner "Ahnenforschung" besteht aber.
Gehe weiter auf Debuggen und dieser Text ist gelb unterlegt

For Each Ding In ActiveWorkbook.VBProject.vbcomponents

Hier der ganze Code

Sub VBA_Code_entfernen()
Dim Ding As Object
Dim Zeile As Long
Dim Antwort As Integer


  For Each Ding In ActiveWorkbook.VBProject.vbcomponents

   'Type 100 = DieseArbeitsmappe und alle Tabellen
    If Ding.Type = 100 Then

      With ActiveWorkbook.VBProject.vbcomponents(Ding.Name).CodeModule
        For Zeile = 1 To .CountOfLines
          .DeleteLines 1
        Next Zeile
      End With

   'Type 1 = Modul, Type 2 = Klassenmodul, Type 3 = UserForm
    Else
      ActiveWorkbook.VBProject.vbcomponents.Remove Ding
    End If

  Next

End Sub

Internette Grüsse
Mick

Hallo Mick,
habe den Code unter meinem Pfad getestet, wird kein Fehler angezeigt. Der Code "VBA_Code_entfernen" wird automatisch mit dem Code zum "Abspeichern" ausgeführt.

Gruß
fedjo

Option Explicit
Sub Abspeichern()
Dim Name As String
Application.ScreenUpdating = False 'Tabellenwechsel unterbinden
Application.DisplayAlerts = False 'Fehlermeldungen werden unterdrückt
ActiveWindow.SelectedSheets.Copy 'Neue Arbeitsmappe wird erstellt
Dim strDateiname As String
strDateiname = Range("C1").Value & " " & Range("E1").Value & ".xls" 'Arbeitsmappe Name = Zelle C1& E1 + xls
ActiveSheet.Shapes("CommandButton1").Cut 'Button werden gelöscht
ActiveSheet.Shapes("CommandButton2").Cut 'Button werden gelöscht
ActiveSheet.Shapes("CommandButton3").Cut 'Button werden gelöscht
Call VBA_Code_entfernen 'Hier wird der Code Ausgeführt
ActiveWorkbook.SaveAs ("C:\Dokumente und Einstellungen\Admin\Desktop\Muster\" & strDateiname) 'Pfad zum Speichern
ActiveWindow.Close 'Arteitsmappe wird geschlossen
ActiveWindow.SelectedSheets.Delete 'Arbeitsblatt wird gelöscht
Application.DisplayAlerts = True 'Fehlermeldungen werden wieder aktiviert
End Sub

Sub VBA_Code_entfernen()
Dim Ding As Object
Dim Zeile As Long
Dim Antwort As Integer
For Each Ding In ActiveWorkbook.VBProject.vbcomponents
'Type 100 = DieseArbeitsmappe und alle Tabellen
If Ding.Type = 100 Then
With ActiveWorkbook.VBProject.vbcomponents(Ding.Name).CodeModule
For Zeile = 1 To .CountOfLines
.DeleteLines 1
Next Zeile
End With
'Type 1 = Modul, Type 2 = Klassenmodul, Type 3 = UserForm
Else
ActiveWorkbook.VBProject.vbcomponents.Remove Ding
End If
Next
End Sub

Hallo fedjo!

Vielen Dank für Deine Mühen, aber wahrscheinlich bin ich zu doof dafür.
Ist es vielleicht Versions abhängig? Arbeite mit Excel 2002.

Alles andere funktioniert aber tadellos. Werde dann die ganze Mappe speichern und alle Blätter die nicht benötigt werden per Hand löschen incl. Module.

Internette Grüsse
Mick

hi all ^^

hier eine ordner abfrage ob vorhanden

gruss nighty

Function VerzeichnisExists(StrPfad As String) As Boolean
On Error Resume Next
    ChDir StrPfad
    If Err = 0 Then VerzeichnisExists = True
End Function  

Hi nighty!

wo steck ich diese Abfrage dazwischen?

Internette Grüsse
Mick

O.K. war wohl bei mir gelegen. Habe mal gegooglet und folgendes gefunden:

Problembeschreibung:
Laufzeitfehler '1004': Der programmatische Zugriff auf das Visual Basic-Projekt ist nicht sicher.

Ursache:
Microsoft Excel 2002 enthält eine neue Sicherheitsfunktion, mit deren Hilfe Sie auswählen können, ob der programmatische Zugriff auf das Visual Basic-Projekt als sicher eingestuft werden sollte.

Standardmäßig wird der programmatische Zugriff auf das Visual Basic-Projekt als nicht sicher eingestuft.

Lösung:
Gehen Sie folgendermaßen vor, um den programmatischen Zugriff auf das Visual Basic-Projekt zuzulassen:

1. Zeigen Sie im Menü Extras auf Makro, und klicken Sie auf Sicherheit.
2. Klicken Sie im Dialogfeld Sicherheit auf die Registerkarte Vertrauenswürdige Quellen.
3. Aktivieren Sie das Kontrollkästchen Zugriff auf Visual Basic-Projekt vertrauen.

Internette Grüsse
Mick

hi all ^^

ich wollte fedjo nicht vorweggreifen,allenfalls ergaenzen

fedjo schreibt es bestimmt gerne um ^^

fuer euch noch eine elegante alternative

gruss nighty

ausserhalb eines allgemeinen moduls

Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long

die naechste zeile erstellt einen angegebenen ordner wenn er nicht existiert,ist in das bestehende makro einzufuegen

MakeSureDirectoryPathExists ("C:\TempTest\")  

Hallo fedjo,

da ich den Laufzeitfehler gefunden habe, konnte ich Dein Zauberwerk testen.

Wäre es möglich, da ich mich in meinem Anfangstread bei meiner Wunschäußerung wohl unglücklich ausgedrückt habe, folgendes zu ändern?

Beim speichern wird mit dem aktuellen Makro das angelegte Familienblatt in einer seperaten Mappe gespeichert und gleichzeitig in der Hauptmappe gelöscht.
Ginge es so, daß das angelegte Blatt, trotz speichern als Einzelmappe ohne Makros und Module, in der Hauptmappe bleibt mit den anderen Familienblättern (mit allen Makros) als Datenbank?

Könnte man folgenden Befehl noch mit einbauen im Speichermakro, um den Laufzeitfehler auszuschliessen. Habe es mit Aufzeichnen probiert, ging aber nicht.
Vor dem Speichern
- Extras -> Makro -> Sicherheit
- Vertrauenwürdige Quellen
- Häckchen bei "Zugriff auf Visual Basic-Projekt vertrauen"

Nachdem Speichern
- Extras -> Makro -> Sicherheit
- Vertrauenwürdige Quellen
- Häckchen bei "Zugriff auf Visual Basic-Projekt vertrauen" wieder weg

Internette Grüsse
Mick

Hallo Mick,
wenn ich deine Wünsch richtig verstehe dann:
Das angelegte Familienblatt wird in der Hauptmappe nicht mehr gelöscht, Button und VBA Code der Tabelle werden gelöscht.

Einen Code über Sicherheit kann man nicht einfügen.
Du könntest aber eine digitale Signatur erzeugen um Makros vertrauenswürdig einzustufen. Digitale Signatur

Pfad anpassen.
Workbooks Name Familenblatt anpassen.
With Workbooks("Familienblatt_Test_001.xls").VBProject.VBComponents(ActiveSheet.CodeName).CodeModule

Option Explicit
Sub Abspeichern()
Dim Name As String
Application.ScreenUpdating = False 'Tabellenwechsel unterbinden
Application.DisplayAlerts = False 'Fehlermeldungen werden unterdrückt
ActiveWindow.SelectedSheets.Copy 'Neue Arbeitsmappe wird erstellt
Dim strDateiname As String
strDateiname = Range("C1").Value & " " & Range("E1").Value & ".xls" 'Arbeitsmappe Name = Zelle C1& E1 + xls
ActiveSheet.Shapes("CommandButton1").Cut 'Button werden gelöscht
ActiveSheet.Shapes("CommandButton2").Cut 'Button werden gelöscht
ActiveSheet.Shapes("CommandButton3").Cut 'Button werden gelöscht
Call VBA_Code_entfernen
ActiveWorkbook.SaveAs ("C:\Dokumente und Einstellungen\Admin\Desktop\Muster\" & strDateiname) 'Pfad zum Speichern
ActiveWindow.Close 'Arteitsmappe wird geschlossen
ActiveSheet.Shapes("CommandButton1").Cut 'Button werden gelöscht
ActiveSheet.Shapes("CommandButton2").Cut 'Button werden gelöscht
ActiveSheet.Shapes("CommandButton3").Cut 'Button werden gelöscht
Call Alle_VBA_Code_in_Tabellenblättern_löschen
Application.DisplayAlerts = True 'Fehlermeldungen werden wieder aktiviert
End Sub
Sub Alle_VBA_Code_in_Tabellenblättern_löschen()
With Workbooks("Familienblatt_Test_001.xls").VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With
End Sub

Sub VBA_Code_entfernen()
Dim Ding As Object
Dim Zeile As Long
Dim Antwort As Integer
For Each Ding In ActiveWorkbook.VBProject.VBComponents

'Type 100 = DieseArbeitsmappe und alle Tabellen
If Ding.Type = 100 Then

With ActiveWorkbook.VBProject.VBComponents(Ding.Name).CodeModule
For Zeile = 1 To .CountOfLines
.DeleteLines 1
Next Zeile
End With
'Type 1 = Modul, Type 2 = Klassenmodul, Type 3 = UserForm
Else
ActiveWorkbook.VBProject.VBComponents.Remove Ding
End If
Next
End Sub
Sub MappenInhaltZusammenstellen()
Range("B9:B100") = ""
Dim Tabelle As Worksheet
Dim i As Integer
ActiveSheet.Name = "Startseite"
i = 10
For Each Tabelle In ActiveWorkbook.Worksheets
Sheets("Startseite").Cells(i, 2).Value = Tabelle.Name
Tabelle.Hyperlinks.Add Anchor:=Cells(i, 2), _
Address:="", SubAddress:=Tabelle.Name & _
"!A1", ScreenTip:="Hyperlink klicken", _
TextToDisplay:=Tabelle.Name
i = i + 1
Next Tabelle ' Startseite, Vorlage löschen
Cells.Find(What:="Startseite", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Replace What:="Startseite", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False

Cells.Find(What:="Vorlage", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Replace What:="Vorlage", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False

'Hyperlinks sortieren
Range("B9:B100").Sort Key1:=Range("B9"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

Gruß
fedjo