Ordner mit Unterordner aus Excel erzeug
13.11.2020 08:06:20
Gerald
Hierzu habe ich eine in meiner Excelliste folgende Spalten definiert:
in Spalte A der Pfad wo die Ordner im Explorer geprüft und angelegt werden sollten;
in Spalte B der Name des Hauptordner;
ab Spalte C, in jeder weiteren Spalte die Namen der Unterordner;
Ich bräuchte hierzu Eure Hilfe, da meine VBA Kenntnisse sehr beschränkt sind :(
mit folgenden gefundenen Makro habe ich es versucht
Option Explicit
' anpassen !!!MIT abschließendem Backslash "\"
Const strPfad1 As String = "H:\Wariwoda_Richter\"
Private Declare PtrSafe Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias _
"DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As LongPtr) As Long
Public Sub Ordner_anlegen()
Dim wksSheet As Worksheet
Dim lngLastRow As Long
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets("Ordner") 'anpassen!
With wksSheet
lngLastRow = .Range("A" & .Rows.Count).End(xlUp).Row ' Spalte A
For lngLastRow = 1 To lngLastRow ' ab Zeile 1 also eventuell anpassen
If Trim(.Cells(lngLastRow, 1).Value) "" Then
MakeSureDirectoryPathExists (strPfad1 & .Cells(lngLastRow, 1).Value & "\" & _
Range("C1") & "\")
MakeSureDirectoryPathExists (strPfad1 & .Cells(lngLastRow, 1).Value & "\" & _
Range("D1") & "\")
MakeSureDirectoryPathExists (strPfad1 & .Cells(lngLastRow, 1).Value & "\" & _
Range("E1") & "\")
End If
Next lngLastRow
End With
Fin:
Set wksSheet = Nothing
End Sub