AW: wer anders kann ja auch...
31.03.2022 11:17:10
UweD
Hallo
ich habe mal Oberschlumpfs Idee aufgegriffen
Vorgabe sieht so aus.
| A | B | C |
1 | Hauptordner1 | Unterordner1 | Unterunterordner1 |
2 | | | Unterunterordner2 |
3 | | | Unterunterordner3 |
4 | Hauptordner2 | Unterordner2 | |
5 | | | Unterunterordner2 |
6 | Hauptordner3 | | |
in ein normales Modul
Sub Struktur()
Dim Pfad As String, LR As Integer, i As Integer, Sp As Integer, LC As Integer, j As Integer
Dim Verz As String, Arr, Brr
Pfad = "\\Server\xx\StartVerz"
Pfad = "E:\Excel\temp\test\" 'Test
If Right(Pfad, 1) = "\" Then ' Sicherestellen, dass kein \ am Ende ist
Pfad = Left(Pfad, Len(Pfad) - 1)
End If
LR = Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
LC = Cells.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte des gesamten Blattes
ReDim Arr(1 To LR, 1 To LC)
ReDim Brr(1 To LR) As String
Arr = Cells(1, 1).Resize(LR, LC)
For i = 1 To LR
For j = 1 To LC
If Cells(i, j) "" Then
Arr(i, j) = Cells(i, j)
Else
If WorksheetFunction.CountBlank(Cells(i, j).Resize(1, LC - j + 1)) LC - j + 1 Then
Arr(i, j) = Arr(i - 1, j) 'wenn leer, dann von oben übernehmen
End If
End If
If Arr(i, j) "" Then Brr(i) = Brr(i) & "\" & Arr(i, j) ' komplette Struktur
If Dir(Pfad & Brr(i), vbDirectory) = "" Then
MkDir Pfad & Brr(i) 'neu anlegen
End If
Next j
Next i
End Sub
LG UweD