automatisches erstellen von Ordnern

Hallo,
ich bin gerade dabei eine Datei zu erstellen die wir folgt ausschaut.
Es geht um eine Übersicht von Projekten bzw auch das Anlegen neuer Projekte.
Ref-Nummer Datum Uhrzeit Verantwortlicher Thema
bl100311 10.03.2015 11:00 bl Dokumentation
Ich gebe hier Datum, Uhrzeit und ein Kürzel ein daraus generiert sich dann meine Referenznummer. =WENN(D5="";"";(D5&LINKS(B5;2)&TEIL(B5;4;2)&LINKS(C5;2)))
Nun möchte ich dass wenn sich die Refernznummer generiert hat, automatisch ein Ordner ersellt und dies immer wieder wenn ein neues Projekt in der Liste angelegt wird.
Ich habe hierzu auch schon mal etwas ähnliches im Netz gefunden, kenne jedioch nicht mehr die genauen Bedeutung der Befehle und schaffe es nicht es für meine Bedürfnisse umzuschreiben.

Private Sub Worksheet_Change(ByVal Target As Range)
Const basisPfad As String = "\\sharedfolder\allgemein\"
Dim fso
Dim pNr As String
Dim pName As String
Dim folderName As String
On Error GoTo fehler
If Target.Cells.Count > 1 Then Exit Sub
If Target.Row > 2 And Target.Column = 1 Or Target.Column = 2 Then
pNr = Me.Cells(Target.Row, "A").Text
pName = Me.Cells(Target.Row, "B").Text
If pNr  "" And pName  "" Then
Set fso = CreateObject("Scripting.FileSystemObject")
folderName = basisPfad & UCase(Left(pName, 1)) & "\"
If Not fso.FolderExists(folderName) Then fso.createFolder folderName
folderName = folderName & pNr & " " & pName & "\"
If Not fso.FolderExists(folderName) Then fso.createFolder folderName
End If
End If
Exit Sub
fehler:
MsgBox "Fehler: " & Err.Description
End Sub

Hier wird noch gleich ein Unterordner erstellt, doch diesen benötige ich für miene Zwecke nicht.
Wäre es auch möglich den Ordner gleich schreibgeschützt zu erstellen, mit einem Passwort dass er sich aus einer Spalte der Tabele zieht?
Im Voraus schon vielen Dank.
Gruß Benny

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,

Option Explicit

'Importiere die Funktion "MakeSureDirectoryPathExists" aus der DLL "imagehlp"
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long

Private Sub Worksheet_Change(ByVal Target As Range)

    'Konstanter Ordnerpfad
    Const FOLDER_PATH As String = "\\sharedfolder\allgemein\"

    Dim lngReturn As Long

    'Springe bei einem Fehler zur angegebenen Sprungmarke
    On Error GoTo err_exit

    'Prüfe ob nur eine Zelle geändert wurde
    If Target.Count = 1 Then
        'Prüfe ob unterhalb Zeile 2 geändert wurde
        If Target.Row > 2 Then
            'Prüfe ob in Spalte B, C, oder D geändert wurde
            If Target.Column = 2 Or Target.Column = 3 Or Target.Column = 4 Then
                'Prüfe ob in Spalte B ein Eintrag vorhanden ist
                If Not IsEmpty(Cells(Target.Row, 2).Value) Then
                    'Prüfe ob in Spalte C ein Eintrag vorhanden ist
                    If Not IsEmpty(Cells(Target.Row, 3).Value) Then
                        'Prüfe ob in Spalte D ein Eintrag vorhanden ist
                        If Not IsEmpty(Cells(Target.Row, 4).Value) Then

                            'Lege den Ordner an
                            lngReturn = MakeSureDirectoryPathExists( _
                                FOLDER_PATH & Cells(Target.Row, 1).Text & "\")

                            'Prüfe ob die Funktion den Wert 0 zurückgegeben hat,
                            'wenn ja, dann löse den Fehelr 70 (Zugriff verweigert) aus
                            If lngReturn = 0 Then Call Err.Raise(70)

                        End If
                    End If
                End If
            End If
        End If
    End If

    Exit Sub

    err_exit:

    'Fehlermeldung ausgeben
    Call MsgBox("Fehler: " & Err.Number & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehlermeldung")

End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

automatisches erstellen von Ordnern

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread