Ordner- und Unterordnerstrukturen anlegen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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

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

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

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

Beliebteste Forumthreads (12 Monate)

Ordner- und Unterordnerstrukturen anlegen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

112 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ordner- und Unterordnerstrukturen anlegen

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

112 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread