Ausgebenen Text kürzen ()
04.02.2019 08:29:10
BoBHeaD
ich hab den Auftrag unsere Ablage neu zu strukturieren. Hierfür habe ich gedacht, dass ich die gesamte Ablage mit Excel durchsuche und mir alle Ordner/ Unterordner anzeigen lasse, diese bis zur 5. Ebene kürze und dann nach Dopplungen suche.
Hier mal ein Beispiel:
X:\Ablagen\123456\1.Überordner\1.Ebene\2.Ebene\3.Ebene\4.Ebene\5.Ebene
Das kürzen von X:\Ablagen\123456\ soll immer erfolgen, weil es ab dem 1. Überordner erst für mich interessant wird. Ich möchte nun alle ab hier bis zur 4. Ebene angezeigt bekommen.
Hier mal das von mir gebastelte, es macht im Groben schon das was es soll. Hier mal mein Code:
Option Explicit
Public Function kurztxt(zelle) As String
Dim versuch As String
Dim Wort, pos1, pos2, pos3, pos4, pos5, anz, was As String
anz = Len(zelle)
versuch = Right(zelle, anz - 22)
was = "\"
anz = Len(versuch) - Len(Replace(versuch, was, "")) ' genaues vergleichen
Wort = versuch
pos1 = InStr(Wort, "\") 'Position erster Punkt
pos2 = InStr(pos1 + 1, Wort, "\") 'Position zweiter Punkt
pos3 = InStr(pos2 + 1, Wort, "\") 'Position dritter Punkt
pos4 = InStr(pos3 + 1, Wort, "\") 'Position vierter Punkt
pos5 = InStr(pos4 + 1, Wort, "\") 'Position fünfter Punkt
zelle = versuch
Select Case anz
Case 1, 2
kurztxt = zelle
Case 3
kurztxt = VBA.Left(zelle, pos3)
Case 4
kurztxt = VBA.Left(zelle, pos4)
Case Else
kurztxt = VBA.Left(zelle, pos5)
End Select
End Function
LG