Ordner und Unterordner per Makro anlegen

Hallo liebes Forum.
Ich bin seit Jahren treuer Leser und habe hier immer Lösungen oder Ideenansätze für meine Probleme gefunden...und konnte diese dann auch immer lösen.
Vielen Dank einfach mal in diese kompetente Runde an dieser Stelle.
Leider komme ich aktuell nicht weiter.
Folgendes Problem stellt sich mir.
Zielordner auf dem Desktop wäre: "Bauprojekte"
Ich habe eine Datei, in welcher in Spalte "A" die Namen von Orten stehen. Das sind so ca. 12000 Stück.
In Spalte "B" habe ich zu den Orten dann die Straßennahmen stehen.
Es kann aber sehr wohl vorkommen, dass in Spalte "A" z.B. 50x Berlin steht und natürlich in Spalte "B" dann 50 Straßen zu Berlin.
Mein Ziel wäre nun, dass das Makro mir im bereits existierenden Oberordner "Bauprojekte" EINEN Ordner "Berlin" anlegt und im Ordner "Berlin" dann jeweils einen Unterordner mit dem Straßennamen aus Spalte "B" angelegt wird.
Ich hoffe, ich habe mich verständlich ausdrücken können und Ihr könnt mir kurz helfen.
Bei Rückfragen bitte immer gern.
Vielen Dank vorab.
Thomas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Option Explicit Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _ ByVal DirPath As String) As Long Public Sub CreateFolders() Dim avntFolders As Variant Dim ialngIndex As Long Dim strTown As String, strMainFolder As String Dim lngReturn As Long strMainFolder = Environ$("ONEDRIVE") & "\Desktop\Bauprojekte\" ' strMainFolder = Environ$("USERPROFILE") & "\Desktop\Bauprojekte\" avntFolders = Range(Cells(1, 1), Cells(Rows.Count, 2).End(xlUp)).Value2 For ialngIndex = LBound(avntFolders, 1) To UBound(avntFolders, 1) If strTown <> avntFolders(ialngIndex, 1) Then strTown = avntFolders(ialngIndex, 1) lngReturn = MakeSureDirectoryPathExists(strMainFolder & strTown & "\") If lngReturn = 0 Then Call MsgBox("Fehler beim anlegen des Ordners " & strTown, vbCritical, "Programmabbruch") Exit Sub End If End If lngReturn = MakeSureDirectoryPathExists(strMainFolder & strTown & "\" & avntFolders(ialngIndex, _ 2) & "\") If lngReturn = 0 Then Call MsgBox("Fehler beim anlegen des Ordners " & avntFolders(ialngIndex, 2), vbCritical, "Programmabbruch") _ Exit Sub End If Next End Sub

Hallo Thomas,
dann so:

Code:


[Cc][+][-]

Option Explicit

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


Public Sub CreateFolders()

  Dim avntFolders As Variant
  Dim ialngIndex As Long
  Dim strTown As String, strMainFolder As String, strRoad As String
  Dim lngReturn As Long

'    strMainFolder = Environ$("ONEDRIVE") & "&bsol;Desktop&bsol;Bauprojekte&bsol;"

  strMainFolder = Environ$("USERPROFILE") & "&bsol;Desktop&bsol;Bauprojekte&bsol;"

  avntFolders = Range(Cells(1, 1), Cells(Rows.Count, 2).End(xlUp)).Value2

  For ialngIndex = LBound(avntFolders, 1) To UBound(avntFolders, 1)

      If strTown <> avntFolders(ialngIndex, 1) Then

         strTown = avntFolders(ialngIndex, 1)

         lngReturn = MakeSureDirectoryPathExists(strMainFolder & strTown & "&bsol;")

         If lngReturn = 0 Then

            Call MsgBox("Fehler beim anlegen des Ordners " & strTown, vbCritical, "Programmabbruch")
            Exit Sub

         End If
      End If

      strRoad = KillForbiddenSigns(avntFolders(ialngIndex, 2))

      lngReturn = MakeSureDirectoryPathExists(strMainFolder & strTown & "&bsol;" & strRoad & "&bsol;")

      If lngReturn = 0 Then

         Call MsgBox("Fehler beim anlegen des Ordners " & avntFolders(ialngIndex, 2), vbCritical, "Programmabbruch") _
              
         Exit Sub

      End If
  Next
End Sub

Private Function KillForbiddenSigns(ByVal pvstrRoad As String) As String
  pvstrRoad = Replace$(pvstrRoad, "", "-")
  pvstrRoad = Replace$(pvstrRoad, "?", "-")
  pvstrRoad = Replace$(pvstrRoad, "*", "-")
  pvstrRoad = Replace$(pvstrRoad, "<", "-")
  pvstrRoad = Replace$(pvstrRoad, ">", "-")
  pvstrRoad = Replace$(pvstrRoad, ".", "-")
  pvstrRoad = Replace$(pvstrRoad, ",", "-")
  pvstrRoad = Replace$(pvstrRoad, "&bsol;", "-")
  pvstrRoad = Replace$(pvstrRoad, "+", "-")
  pvstrRoad = Replace$(pvstrRoad, ":", "-")
  pvstrRoad = Replace$(pvstrRoad, "=", "-")
  pvstrRoad = Replace$(pvstrRoad, "/", "-")
  pvstrRoad = Replace$(pvstrRoad, ";", "-")
  pvstrRoad = Replace$(pvstrRoad, "[", "-")
  pvstrRoad = Replace$(pvstrRoad, "]", "-")
  pvstrRoad = Replace$(pvstrRoad, "|", "-")
  pvstrRoad = Replace$(pvstrRoad, Chr$(34), "-")
  KillForbiddenSigns = pvstrRoad
End Function

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Ordner und Unterordner per Makro anlegen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

112 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ordner und Unterordner per Makro anlegen

9 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)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread