Automatisch Ordner erstellen

Ylmz-006 · 2020-09-04T11:25:28+00:00

Hallo Ihr Lieben, wie kann ich aus Excel heraus per VBA einen Ordner im Explorer anlegen? z.B. Wenn ich in meiner Intell. Tabelle eine Nummer in Spalte "B" eingebe, soll ein Ordner unter "C:\Users\Technik\Pictures\Akten\" erstellt werden. Das Nummerierungsschema in Spalte B "lautet 000_1234567_00

Hallo Ylmz,
der komplette Code im Modul der Tabelle:

Option Explicit

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

Private Const FOLDER_PATH As String = "C:\Users\Technik\Pictures\Akten\"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objRange As Range, objcell As Range
    Dim lngReturn As Long
    Call ProjektArchivieren(Target)
    Set objRange = Intersect(Target, Columns(2))
    If Not objRange Is Nothing Then
        For Each objcell In objRange
            If Not IsEmpty(objcell.Value) Then
                lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & objcell.Text & "\")
                If lngReturn = 0 Then Call MsgBox("Ordner " & objcell.Text & _
                    " konnte nicht erstellt werden.", vbCritical, "Dateisystemfehler")
            End If
        Next
        Set objRange = Nothing
    End If
    If Not Intersect(Target, Range("B:Y")) Is Nothing Then
        Range("M12").CurrentRegion.Sort Key1:=Range("M12"), _
            Order1:=xlAscending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim strFoldername As String, strAlternativeFoldername As String
    If Target.Column = 2 Then
        strAlternativeFoldername = Replace(Replace(Target.Text, "/", "-"), "-", "_")
        strFoldername = Dir$(FOLDER_PATH & "*" & _
            Replace(Target.Text, "/", "-") & "*", vbDirectory)
        If strFoldername = vbNullString Then strFoldername = _
            Dir$(FOLDER_PATH & "*" & strAlternativeFoldername & "*", vbDirectory)
        If strFoldername <> vbNullString Then
            Call Shell("explorer.exe /e, " & FOLDER_PATH & strFoldername, vbNormalFocus)
        Else
            Call MsgBox("Ordner nicht gefunden.", vbExclamation, "Hinweis")
        End If
        Cancel = True
    End If
End Sub

Wie schon geschrieben, du musst Excel mit Adminrechten öffnen damit du Ordner erstellen kannst.
Gruß
Nepumuk

Hallo Nepumuk,
Es geht wieder. Super Danke...
Nur habe ich ein Kkleines Problem noch.
Beim verschieben der erledigten Aufgaben auf anderen Blatt, kommt ein Fehler in VBA " Set objRange = Intersect(Target, Columns(2))"
In der Makro Habe ich folgende Code stehen.
Option Explicit
Option Compare Text
Dim iLastRow As Long
Sub ProjektArchivieren(ByVal Target As Range)
Dim WSh As Worksheet, iTab As Object
Dim iZeile As Long
If Target.Column = 13 And Target.Row > 12 Then
Set WSh = Sheets("Archiv")
Set iTab = WSh.ListObjects("Tabelle13")
On Error GoTo ErrorHandler
iLastRow = 0
If Target.Value Like "erledigt" Then
Application.EnableEvents = False
iTab.ListRows.Add
iLastRow = Target.Row
iZeile = iTab.ListRows.Count + 11
WSh.Range("B" & iZeile & ":Y" & iZeile).Value _
= Range("B" & iLastRow & ":Y" & iLastRow).Value
Rows(iLastRow).Delete
End If
Application.EnableEvents = True
End If
Exit Sub
ErrorHandler:
MsgBox "Es ist der Fehler '" & Error & "' aufgetreten!", vbCritical, "Projekt verschieben"
Application.EnableEvents = True
End Sub
Sub ProjektReaktivieren(ByVal Target As Range)
Dim WSh As Worksheet, iTab As Object
Dim iZeile As Long, iZeile2 As Long
If Target.Column = 13 And Target.Row > 12 Then
Set WSh = Sheets("Aktuell")
Set iTab = WSh.ListObjects("Tabelle1")
On Error GoTo ErrorHandler
If Target.Value Like "Zurück nach Aktuell" Then
Application.EnableEvents = False
iZeile = iLastRow
If iZeile = 0 Or iZeile > iTab.ListRows.Count + 11 Then
iTab.ListRows.Add
iZeile = iTab.ListRows.Count + 11
Else
WSh.Range("A" & iZeile).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
iZeile2 = Target.Row
WSh.Range("B" & iZeile & ":Y" & iZeile).Value _
= Range("B" & iZeile2 & ":Y" & iZeile2).Value
WSh.Range("M" & iZeile).Value = ""
Rows(iZeile2).Delete
iLastRow = 0
End If
Application.EnableEvents = True
End If
Exit Sub
ErrorHandler:
MsgBox "Es ist der Fehler '" & Error & "' aufgetreten!", vbCritical, "Projekt verschieben"
Application.EnableEvents = True
End Sub
..und in der Tabellenreiter Archiv folgendes:
Option Explicit
Private Const FOLDER_PATH As String = "C:\Users\Technik\Pictures\Akten\"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim strFoldername As String, strAlternativeFoldername As String
If Target.Column = 2 Then
strAlternativeFoldername = Replace(Replace(Target.Text, "/", "-"), "-", "_")
strFoldername = Dir$(FOLDER_PATH & "*" & _
Replace(Target.Text, "/", "-") & "*", vbDirectory)
If strFoldername = vbNullString Then strFoldername = _
Dir$(FOLDER_PATH & "*" & strAlternativeFoldername & "*", vbDirectory)
If strFoldername  vbNullString Then
Call Shell("explorer.exe /e, " & FOLDER_PATH & strFoldername, vbNormalFocus)
Else
Call MsgBox("Ordner nicht gefunden.", vbExclamation, "Hinweis")
End If
Cancel = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
ProjektReaktivieren Target
End Sub

Forumthread: Automatisch Ordner erstellen

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Automatisch Ordner erstellen

Forumthread: Automatisch Ordner erstellen

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread