Algorithmus Zähler in mehreren Ebenen

Hallo Forumsmitglieder,
ich habe ein kleines Problem bei der Anlage einer Ordnerstruktur mit enthaltener Nummerierung. Mit der angehangene Datei

Die Datei https://www.herber.de/bbs/user/105897.xlsm wurde aus Datenschutzgründen gelöscht

kann ich mir eine Ordnerstruktur aufbauen.
Den Code habe ich teilweise aus dem Internet und teilweise selbst gebastelt.
Mein Problem besteht nun darin, dass ich jedem anzulegenden Ordner eine Nummer voranstellen möchte. Durch die Nummerierung lassen sich die Ordner beim navigieren über den Explorer besser sortieren und man kann den Kollegen kurz sagen "gehe in Ordner ...01...03...12...03..."
Leider schaffe ich es nicht, dass er mir mit jeder tieferen Ebene immer wieder den Counter auf 0 bzw. 1 zurücksetzt :-(
In der Datei ist ein Sheet mit meinem "Soll", damit man es sich optisch einigermaßen vorstellen kann.
Kann mir bitte jemand helfen?
Danke und Grüße, Bernd

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub TestIt() Dim lngLR As Long Dim lngFldr() As Long Dim strFldr() As String Dim i As Long, j As Long, k As Long Dim blnFnd As Boolean Const COLMAX As Long = 5 Const COLRES As Long = 7 ReDim lngFldr(1 To COLMAX) ReDim strFldr(1 To COLMAX) With Sheets("Test") lngLR = .UsedRange.SpecialCells(xlCellTypeLastCell).Row .Cells(5, COLRES).Resize(lngLR, 4).ClearContents For i = 5 To lngLR blnFnd = False For j = 1 To COLMAX If .Cells(i, j) "" Then blnFnd = True lngFldr(j) = lngFldr(j) + 1 strFldr(j) = "\" & Format(lngFldr(j), "00") & "_" & .Cells(i, j) If j = 1 Then strFldr(j) = .Cells(2, 1) & strFldr(j) End If For k = j + 1 To COLMAX lngFldr(k) = 0 strFldr(k) = "" Next End If Next If blnFnd Then For j = 1 To COLMAX If lngFldr(j) = 0 Then Exit For .Cells(i, COLRES) = .Cells(i, COLRES) & strFldr(j) Next End If Next End With End Sub

Hi Bernd,
das geht z.B. so:

Option Explicit
'In VBA muß man jede Variabel EINZELN deklarieren; mehrere mit , getrennte
'sind zunächst immer VARIANT;
'es geht auch die Kurzschreibweise & = as long bzw. $ = as string
'Dim maxzeile, maxspalte, ae, i, j, Counter As Long
'Dim Pfad, strpath As String
Dim maxzeile&, maxspalte&, ae&, i&, j&, Counter&
Dim Pfad$, strpath$
Dim ws As Worksheet
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) _
As Long
Sub Pfade_anlegenMichael()
Dim a As Variant, e&(), eS$(), au As Variant
Dim z&, s& 'z wie Zeile, s wie Spalte
'das werden bzw. sind Arrays
Sheets("Test").Activate
maxzeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
If maxzeile  "\" Then Pfad = Pfad & "\"
a = Range("A5").Resize(maxzeile - 4, maxspalte)
au = Range("G5:G" & maxzeile)
ReDim e(1 To 1, 1 To maxspalte)
ReDim eS(1 To 1, 1 To maxspalte)
For z = 1 To maxzeile - 4
s = 0
For i = 1 To maxspalte
If a(z, i)  "" Then
s = i
e(1, i) = e(1, i) + 1
eS(1, i) = Format(e(1, s), "00") & "_" & a(z, i)
Else
If s > 0 Then e(1, i) = 0: eS(1, i) = ""
End If
Next
a(z, s) = Format(e(1, s), "00") & "_" & a(z, s)
au(z, 1) = Pfad
For i = 1 To s
au(z, 1) = au(z, 1) & eS(1, i) & "\"
Next
Next
Range("A5").Resize(maxzeile - 4, maxspalte) = a
Range("G5:G" & maxzeile) = au
End Sub

Das Makro läuft NICHT mit Leerzeilen, also bitte: lösche die leeren Zeilen 26 und 27 raus, sonst müßte man extra noch eine Abfrage einbauen.
Datei mit einer Spalte mehr (testhalber): https://www.herber.de/bbs/user/105911.xlsm
Schöne Grüße,
Michael

Beliebteste Forumthreads (12 Monate)

Algorithmus Zähler in mehreren Ebenen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread