Microsoft Excel

Excel und VBA: Beitrag aus Herbers Excel-Forumsarchiv

Ordner- und Unterordnerstrukturen anlegen

auftragsprogrammierung | excel-cd

Betrifft: Ordner- und Unterordnerstrukturen anlegen
von: sruhsam
Geschrieben am: 25.01.2011 11:19:42

Hallo Profis
habe ein Problem beim automatischen erstellen von Verzeichnisse aus Excel heraus.
Ziel ist es durch die in Excel eingegebene Daten eine Ordnerstruktur zu erstellen. Dies soll in 3 Stufen gegliedert sein.
1. Stufe:
Einfaches erstellen von Verzeichnisse im Pfad (B1). Die Ordnernamen sollen dabei so heisen wie die Werte der Zellen A4 bis A100.
2.Stufe:
Erstellen von Unterordner in alle Ordner der Stufe 1(A4 bis A100)
Die Unterordner sollen dabei so heisen wie die Werte der Zellen C4 bis C100.
3.Stufe
Erstellen von weitere Unterordner der Stufe 2 (C4 bis C100)
Die Unterordner sollen dabei so heisen wie die Werte der Zellen E4 bis E100.

Grundsätzlich sollen bereits vorhandene Orden oder Unterordner nicht neu erstellt werden. Leerzeilen können übersprungen werden.
Beim klick auf "alle" werden alle Ordner erstellt. Beim Klick auf "einzeln" nur die der aktiven Zelle

Habe gedacht dies über mehrere Schaltflächen die den Stufen zugeordnet sind zu machen.

Kann mir hier jemand helfen?

Anbei Beispieldatei: http://www.herber.de/bbs/user/73222.xls

  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: Josef Ehrensberger
Geschrieben am: 25.01.2011 11:45:57


Hallo ?,

heir mal ein Ansatz für alle Ordner.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub alle()
  Dim lngRow As Long, lngLast As Long
  Dim strPath As String
  
  lngLast = Application.Max(4, Cells(Rows.Count, 1).End(xlUp).Row)
  
  
  For lngRow = 4 To lngLast
    strPath = ""
    If Cells(lngRow, 1) <> "" Then
      strPath = IIf(Right(Range("b1").Text, 1) = "\", Range("B1").Text, Range("B1").Text & "\")
      If Cells(lngRow, 1) <> "" Then
        strPath = strPath & IIf(Right(Cells(lngRow, 1).Text, 1) = "\", Cells(lngRow, 3).Text, _
          Cells(lngRow, 1).Text & "\")
        
        If Cells(lngRow, 3) <> "" Then
          strPath = strPath & IIf(Right(Cells(lngRow, 3).Text, 1) = "\", Cells(lngRow, 3).Text, _
            Cells(lngRow, 3).Text & "\")
          
          If Cells(lngRow, 5) <> "" Then
            strPath = strPath & IIf(Right(Cells(lngRow, 5).Text, 1) = "\", Cells(lngRow, 5).Text, _
              Cells(lngRow, 5).Text & "\")
          End If
        End If
      End If
    End If
    If Len(strPath) Then MakeSureDirectoryPathExists strPath
  Next
End Sub


P.S.: Ein Ordnername mit / ist ungültig!




Gruß Sepp



  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: Tino
Geschrieben am: 25.01.2011 11:51:38

Hallo,
müsste so funktionieren,
allerdings kannst Du für einen Ordnernamen keine Sonderzeichen
wie /?! usw... verwenden.

Option Explicit

Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long

Sub Test()
Dim sPahth As String
Dim A As Long, B As Long, C As Long
Dim Array1(), Array2(), Array3(), sOrnder$

With Tabelle1
    Array1 = .Range("A4", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value2
    Array2 = .Range("C4", .Cells(.Rows.Count, 3).End(xlUp)).Resize(, 2).Value2
    Array3 = .Range("E4", .Cells(.Rows.Count, 5).End(xlUp)).Resize(, 2).Value2
    
    Redim Preserve Array1(1 To Ubound(Array1), 1 To 1)
    Redim Preserve Array2(1 To Ubound(Array2), 1 To 1)
    Redim Preserve Array3(1 To Ubound(Array3), 1 To 1)
    
    sPahth = .Cells(1, 2)
    sPahth = IIf(Right$(sPahth, 1) = "\", sPahth, sPahth & "\")
End With

For A = 1 To Ubound(Array1)
    For B = 1 To Ubound(Array2)
        sOrnder = Array1(A, 1)
        If Right$(sOrnder, 1) <> "\" Then
            sOrnder = sOrnder & "\"
        End If
        sOrnder = sOrnder & Array2(B, 1)
        
        For C = 1 To Ubound(Array3)
            If Right$(sOrnder, 1) <> "\" Then
                sOrnder = sOrnder & "\"
            End If
            apiCreateFullPath sPahth & sOrnder & Array3(C, 1)
        Next
    Next
Next

End Sub
Gruß Tino


  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: Tino
Geschrieben am: 25.01.2011 11:56:06

Hallo,
mach aus der Zeile

apiCreateFullPath sPahth & sOrnder & Array3(C, 1)
diese zwei Zeilen
Array3(C, 1) = IIf(Right$(Array3(C, 1), 1) = "\", Array3(C, 1), Array3(C, 1) & "\")
apiCreateFullPath sPahth & sOrnder & Array3(C, 1)
Gruß Tino


  

Betrifft: gekürzte Variante
von: Tino
Geschrieben am: 25.01.2011 12:22:41

Hallo,
hier noch eine gekürzte Variante.

Option Explicit

Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long

Sub Test()
Dim sPahth As String
Dim A As Long, B As Long, C As Long
Dim Array1(), Array2(), Array3(), sOrnder$

With Tabelle1
    Array1 = .Range("A4", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value2
    Array2 = .Range("C4", .Cells(.Rows.Count, 3).End(xlUp)).Resize(, 2).Value2
    Array3 = .Range("E4", .Cells(.Rows.Count, 5).End(xlUp)).Resize(, 2).Value2

    sPahth = IIf(Right$(.Cells(1, 2), 1) = "\", .Cells(1, 2), .Cells(1, 2) & "\")
End With

For A = 1 To Ubound(Array1)
    For B = 1 To Ubound(Array2)
        sOrnder = Replace(Array1(A, 1), "\", "")
        sOrnder = sOrnder & "\" & Replace(Array2(B, 1), "\", "")
        For C = 1 To Ubound(Array3)
            apiCreateFullPath sPahth & sOrnder & "\" & Replace(Array3(C, 1), "\", "") & "\"
        Next
    Next
Next

End Sub
Gruß Tino


  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: sruhsam
Geschrieben am: 25.01.2011 12:51:35

Hallo Timo, Lösung funktioniert bestens. Supper habe nicht so schnell mit einer Lösung gerrechnet.
Können wir noch abfangen, wenn Ordner in der Struktur bereits existieren, daß diese angezeigt werden und entschieden werden kann ob überschrieben werden darf oder nicht?
Grüße
Stephan
http://www.herber.de/bbs/user/73223.xls


  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: Tino
Geschrieben am: 25.01.2011 13:31:02

Hallo,
bei dieser API Funktion werden vorhandene Ordner nicht überschrieben
sondern nur nichtvorhandene angelegt.

Du kannst aber enthaltene Dateien löschen.

Beispiel:

Option Explicit

Private Declare Function apiCreateFullPath _
Lib "imagehlp.dll" Alias "MakeSureDirectoryPathExists" (ByVal lpPath As String) As Long

Sub Test()
Dim sPahth As String
Dim A As Long, B As Long, C As Long
Dim Array1(), Array2(), Array3(), sOrnder$
Dim lngPath As Long, intMsg As Integer

With Tabelle1
    Array1 = .Range("A4", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value2
    Array2 = .Range("C4", .Cells(.Rows.Count, 3).End(xlUp)).Resize(, 2).Value2
    Array3 = .Range("E4", .Cells(.Rows.Count, 5).End(xlUp)).Resize(, 2).Value2

    sPahth = IIf(Right$(.Cells(1, 2), 1) = "\", .Cells(1, 2), .Cells(1, 2) & "\")
End With

intMsg = MsgBox("Sollen vorhandene Dateien gelöscht werden?", vbYesNo + vbQuestion)
For A = 1 To Ubound(Array1)
    For B = 1 To Ubound(Array2)
        sOrnder = Replace(Array1(A, 1), "\", "")
        sOrnder = sOrnder & "\" & Replace(Array2(B, 1), "\", "")
        For C = 1 To Ubound(Array3)
           lngPath = apiCreateFullPath(sPahth & sOrnder & "\" & Replace(Array3(C, 1), "\", "") & "\")
           If intMsg = vbYes Then
            If lngPath <> 0 Then
                 If Dir(sPahth & sOrnder & "\" & Replace(Array3(C, 1), "\", "") & "\*.*", vbNormal) <> "" Then
                     Kill sPahth & sOrnder & "\" & Replace(Array3(C, 1), "\", "") & "\*.*"
                 End If
            End If
           End If
        Next
    Next
Next

End Sub
Bin jetzt nicht mehr Online

Gruß Tino


  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: sruhsam
Geschrieben am: 25.01.2011 13:35:15

Hallo Timo, Lösung funktioniert bestens. Supper habe nicht so schnell mit einer Lösung gerrechnet.

Können wir noch folgendes abfangen,
1.) wenn Ordner in der Struktur bereits existieren, daß diese angezeigt werden und entschieden werden kann ob überschrieben werden darf oder nicht?

2.) wenn keine Werte in der 3. oder 2. oder 1. Stufe eingegeben werden soll auch in der betreffenden Stufe nichts passieren.
Ist in der 2. und 3. Stuffe nichts drinn soll nur die 1. Stufe berücksichtigt werden.
Ist in der 3. Stufe nichts angegeben, sollen nur die ersten beiden Stufen berücksichtigt werden.

Grüße
Stephan
Anbei die bisherige Datei in der ich die Korrektur eingebracht habe!
http://www.herber.de/bbs/user/73223.xls


  

Betrifft: AW: Ordner- und Unterordnerstrukturen anlegen
von: Tino
Geschrieben am: 26.01.2011 07:54:37

Hallo,
hier die Datei, kannst ja mal testen.

http://www.herber.de/bbs/user/73240.xls

Gruß Tino


 
Screenshots zu den Aufrufoberflächen der Excel-Materialien

Grundwerk | Tutorial | Dialoge | Archiv | Excel-Basics | VBA-Basics


Copyright © 2012 Hans W. Herber