Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Automatisch Ordner erstellen

Betrifft: Automatisch Ordner erstellen von: Ylmz-006
Geschrieben am: 04.09.2020 11:25:28

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

Betrifft: AW: Automatisch Ordner erstellen
von: UweD
Geschrieben am: 04.09.2020 11:48:07

Hallo


- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Code rechts reinkopieren

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Pfad As String
    
    Pfad = "C:\Users\Technik\Pictures\Akten\"
    
    If Not Intersect(Range("B:B"), Target) Is Nothing Then
        If Target <> "" Then
            If Dir(Pfad & Target.Value, vbDirectory) = "" Then
                MkDir Pfad & Target.Value
            Else
                MsgBox Target.Value & ": existiert schon"
            End If
            
        End If
    
    End If

End Sub

LG UweD

Betrifft: AW: Automatisch Ordner erstellen
von: UweD
Geschrieben am: 04.09.2020 12:00:24

Hatte es anders verstanden...
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Pfad As String, Verz As String

    Pfad = "C:\Users\Technik\Pictures\Akten\"
    
    If Not Intersect(Range("B:B"), Target) Is Nothing Then
        If Target <> "" Then
            Verz = "000_" & Target.Value & "_00"
            If Dir(Pfad & Verz, vbDirectory) = "" Then
                MkDir Pfad & Verz
            Else
                MsgBox Verz & ": existiert schon"
            End If

        End If

    End If

End Sub


Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 12:01:03

Hallo UweD,

vielen Dank für dein unterstützung.

Ich habe in der Tabellenblattreiter noch einige Code drin stehen. Wie kann ich diese Code dazufügen?
Es erscheint ein Fehler beim Kompilieren: Mehrdeutige Name: Worsheet_Change.

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 04.09.2020 12:06:40

Hallo Ylmz,

zeig doch mal das vorhandene Change-Event.

Gruß
Nepumuk

Betrifft: AW: Automatisch Ordner erstellen
von: volti
Geschrieben am: 04.09.2020 11:52:54

Hallo,

hier eine (ungetestete) Variante. Code muss ins Tabellenmodul:

 
[Cc]
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _ ByVal lpPath As String) As Long Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then If Target.Value <> "" Then MakeSureDirectoryPathExists "C:\Users\Technik\Pictures\Akten\000_" & Target.Value & "_00\" End If End If End Sub
 
____________________
viele Grüße aus Freigericht
Karl-Heinz


Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 04.09.2020 12:01:49

Hallo Ylmz,

theoretisch so:

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
    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
End Sub

ABER, um in C:\Users einen Ordner zu erstellen benötigst du Adminrechte. Sichtbar an dem blau-gelben Schild wenn du das manuell machts. Ein VBA-Code kann nur Adminrechte haben, wenn du die Excel.exe per Rechtsklick "Als Administrator ausführen" startest und dann darin deine Mappe öffnest.

Gruß
Nepumuk

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 12:16:22

Hallo Nepumuk,

Diese Code habe ich in der Tabellenreiter stehen.

Gruß

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)
   ProjektArchivieren Target
On Error Resume Next
If Not Intersect(Target, Range("B:Y")) Is Nothing Then
Range("M12").Sort Key1:=Range("M12"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End If
End Sub


Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 04.09.2020 12:28:17

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

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 12:43:29

Hallo Nepumuk,

Es schint zu funktionieren.

Nur das Nummerierungsschema in Spalte B "ist wie folgt 000-1234567/00 Ordnerstruktur ist 000_1234567_00
kann mann das noch ändern?

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 04.09.2020 12:50:37

Hallo Ylmz,

ändere diese Zeile:

lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & objcell.Text & "\")

so:

lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & Replace(Replace(objcell.Text, "/", "-"), "-", "_") & "\")

Gruß
Nepumuk

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 13:17:53

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


Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 04.09.2020 14:56:39

Hallo Ylmz,

ändere das Change-Event so:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objRange As Range, objcell As Range
    Dim lngReturn As Long
    If Target.Column = 13 And Target.Row > 12 Then
        Call ProjektArchivieren(Target)
    Else
        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 & _
                        Replace(Replace(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
    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

Gruß
Nepumuk

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 15:22:21

Hallo Nepumuk,

die Zeile wird jetzt verschoben aber bekomme die Laufzeitfehler 1004
Interselect für das Projekt´- Global ist fehlgeschlagen.

VBA gibt die fehler bei "If Not Intersect(Target, Range("B:Y")) Is Nothing Then"

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 04.09.2020 16:20:38

Hallo Ylmz,

das kommt daher dass du die Zeile mit dem Target löschst. Dann so:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objRange As Range, objcell As Range
    Dim lngReturn As Long
    If Target.Column = 13 And Target.Row > 12 Then
        Call ProjektArchivieren(Target)
    Else
        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 & _
                        Replace(Replace(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 If
End Sub

Gruß
Nepumuk

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 17:05:54

Hallo Nepumuk,

Vielen Dank für dein unterstützung und alle anderen, die geholfen haben.

bis auf die auto sortierfunktion geht alles. Das ist aber nicht so schlimm.

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 07.09.2020 08:24:30

Hallo Zusammen,

sowie es aussieht, benötige ich doch die Sortierfunktion.
Kann mann das noch in den Code integrieren?

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: Nepumuk
Geschrieben am: 07.09.2020 09:06:13

Hallo Ylmz,

nachdem du nach Spalte M sortierst, genügt es doch, wenn du bei Änderung in Spalte M sortierst. Das ginge dann so:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim objRange As Range, objcell As Range
    Dim lngReturn As Long
    If Target.Column = 13 And Target.Row > 12 Then
        Call ProjektArchivieren(Target)
        Range("M12").CurrentRegion.Sort Key1:=Range("M12"), _
            Order1:=xlAscending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom
    Else
        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 & _
                        Replace(Replace(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
    End If
End Sub

Gruß
Nepumuk

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 07.09.2020 10:25:52

Hallo Nepumuk,

Großartig.. Danke dir.

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 12:30:21

Falls ich aber unbedingr Adminrechte benötige, ist die sache schon erledigt. Die habe ich nämmlich nicht auf der Firmen-Pc.

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: Ylmz-006
Geschrieben am: 04.09.2020 12:30:38

Falls ich aber unbedingr Adminrechte benötige, ist die sache schon erledigt. Die habe ich nämmlich nicht auf der Firmen-Pc.

Gruß

Betrifft: AW: Automatisch Ordner erstellen
von: UweD
Geschrieben am: 04.09.2020 12:40:35

Das lässt sich doch feststellen, indem du den Ordner mal "von Hand "erstellst.

Gehts oder nicht?

Beiträge aus dem Excel-Forum zum Thema "Automatisch Ordner erstellen"