Ahnenforschung Familienblatt

Question

Hallo Ihr Lieben,

Ich bin unter die Ahnenforscher gegangen und habe mir zur Erleichterung eine Eheschliessungstabelle der einzelnen Familien gebastelt.
Nun bräuchte ich Eure Hilfe bei diversen Makros. Ich versuche meine Problemchen so genau wie möglich zu beschreiben.
Die Datei baut sich wie folgt auf:

1. Tabellenblatt = Startseite
auf dieser Seite habe ich einen Button "Neues Familienblatt einfügen" das ich mit diesem Makro gelöst habe

Public Sub Vorlage()

Sheets("Vorlage").Visible = True

Dim strName As String
strName = InputBox("Familie eingeben", "Eingabe", "Familiennamen")
If strName = "" Then Exit Sub
ThisWorkbook.Worksheets("Vorlage").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = strName

Sheets("Vorlage").Visible = False

End Sub

Von Zelle A9 soll nach unten hin immer die laufende Nummer angezeigt werden wenn die Nachbarzelle B9 nach unten hin eine Namenspaarung beinhaltet.

2. Tabellenblatt = Vorlage
Dieses Blatt ist das Grundgerüst für die ganzen Daten, die auch Formeln enthalten um das Alter zu errechnen.
Dieses Tabellenblatt ist ausgeblendet und enthält zwei Buttons "Liste leeren" und "zurück zur Startseite".

So nun meine Probleme oder Wünsche:
Im Tabellenblatt "Vorlage" würde ich noch gerne eine Makro "Speichern" einbauen, was mir nur das Aktive Tabellenblatt unter den Namen die in Zelle C1 und E1 stehen, unter M:\BackUp_Eigene Dateien\Ahnenforschung als Einzeldatei abspeichert. Bsp.: Speicherort\GeburtsnameA - GeburtsnameB.
Gespeichert werden soll dann dieses Blatt mit Formeln, aber ohne Module, Buttons und Makros.

Beim "Neues Familienblatt einfügen" (siehe Code oben) soll das neue Blatt ohne dem Button, Modul und Makro "Liste leeren" eingefügt werden.

Und mein letzter Wunsch wäre, daß auf der Startseite alle Familienpaarungs-Blätter von Zelle B9 an runterwärts aufgelistet und auf das dementsprechende Blatt verlinkt und sortiert sind. Ausgenommen Startseite und Vorlage.

Sind diese Wünsche möglich? Ich hoffe auf Eure Hilfe, da das Makroschreiben bei mir nur auf das Makro-Aufnehmen beschränkt ist.

Damit Ihr Euch mein Konstrukt vorstellen könnt habe ich es hier hochgeladen.

Internette Grüsse
Mick

Answer 1

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

Answer 2

Hi nighty!

wo steck ich diese Abfrage dazwischen?

Internette Grüsse
Mick

Answer 3

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

Answer 4

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\")

Answer 5

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

Answer 6

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.

Extras -> Makro -> Sicherheit

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