Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1780to1784
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Automatisch Ordner erstellen

Automatisch Ordner erstellen
04.09.2020 11:25:28
Ylmz-006
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

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

Betreff
Datum
Anwender
Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 11:48:07
UweD
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
AW: Automatisch Ordner erstellen
04.09.2020 12:00:24
UweD
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

Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 12:01:03
Ylmz-006
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ß
AW: Automatisch Ordner erstellen
04.09.2020 12:06:40
Nepumuk
Hallo Ylmz,
zeig doch mal das vorhandene Change-Event.
Gruß
Nepumuk
AW: Automatisch Ordner erstellen
04.09.2020 11:52:54
volti
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:&bsol;Users&bsol;Technik&bsol;Pictures&bsol;Akten&bsol;000_" & Target.Value & "_00&bsol;" End If End If End Sub
 
____________________
viele Grüße aus Freigericht
Karl-Heinz

Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 12:01:49
Nepumuk
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
Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 12:16:22
Ylmz-006
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

Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 12:28:17
Nepumuk
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
Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 12:43:29
Ylmz-006
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ß
AW: Automatisch Ordner erstellen
04.09.2020 12:50:37
Nepumuk
Hallo Ylmz,
ändere diese Zeile:
lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & objcell.Text & "\")
so:
lngReturn = MakeSureDirectoryPathExists(FOLDER_PATH & Replace(Replace(objcell.Text, "/", "-"), "-", "_") & "\")
Gruß
Nepumuk
AW: Automatisch Ordner erstellen
04.09.2020 13:17:53
Ylmz-006
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

Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 14:56:39
Nepumuk
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
Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 15:22:21
Ylmz-006
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ß
AW: Automatisch Ordner erstellen
04.09.2020 16:20:38
Nepumuk
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
Anzeige
AW: Automatisch Ordner erstellen
04.09.2020 17:05:54
Ylmz-006
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ß
AW: Automatisch Ordner erstellen
07.09.2020 08:24:30
Ylmz-006
Hallo Zusammen,
sowie es aussieht, benötige ich doch die Sortierfunktion.
Kann mann das noch in den Code integrieren?
Gruß
AW: Automatisch Ordner erstellen
07.09.2020 09:06:13
Nepumuk
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
Anzeige
AW: Automatisch Ordner erstellen
07.09.2020 10:25:52
Ylmz-006
Hallo Nepumuk,
Großartig.. Danke dir.
AW: Automatisch Ordner erstellen
04.09.2020 12:30:21
Ylmz-006
Falls ich aber unbedingr Adminrechte benötige, ist die sache schon erledigt. Die habe ich nämmlich nicht auf der Firmen-Pc.
Gruß
AW: Automatisch Ordner erstellen
04.09.2020 12:30:38
Ylmz-006
Falls ich aber unbedingr Adminrechte benötige, ist die sache schon erledigt. Die habe ich nämmlich nicht auf der Firmen-Pc.
Gruß
AW: Automatisch Ordner erstellen
04.09.2020 12:40:35
UweD
Das lässt sich doch feststellen, indem du den Ordner mal "von Hand "erstellst.
Gehts oder nicht?

57 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige