AVAIL_FolderTags Split "Folder path" into Tags - some exclusion frameworks - rough VBA ©Ron Allen all rights reserved

Attribute VB_Name = "AVAIL_FolderTags" Option Explicit Option Compare Text Const vbqt = """" ''quote quick reference in string ''GENERATE FOLDER TAGS FOR AVAIL EXPORTS ''get 1st worksheet ''get (only) first list object Sub Add_FolderTags_To_Table() ''run on open or add to XLSM Dim ws As Worksheet ''Active worksheet Dim LI As ListObject ''List object AKA Table Dim lc As ListColumn ''List Column reference for formulas Dim found As Boolean ''boolean for search Dim c As Range ''Column Dim r As Range ''Row Set ws = ActiveWorkbook.ActiveSheet ''Active workbook Set LI = ws.ListObjects(1) ''ONE table per sheet with TSV ''Check for PATH column header- if nothing the set and name it On Error Resume Next: Set lc = LI.ListColumns("Path"): On Error GoTo 0 If lc Is Nothing Then Set lc = LI.ListColumns.Add(LI.ListColumns.Count + 1) lc.Name = "Path" End If lc.DataBodyRange.Formula = "=AVAIL_FolderTags([@Filepath],3,3)" 'For Each r In LI.ListColumns("Filepath").DataBodyRange.Rows ' lc.Range(r.Row, 1).Value = AVAIL_FolderTags(r.Value) 'Next r End Sub Sub FuncDef() Call FunctionRegisterDescriptions( _ "AVAIL_FolderTags", _ "Generates tags based on the path provided with some limiting features.", _ 16, _ Arr1( _ "FULL Filepath including \FileName.ext", _ "OPTIONAL '0' is Drive/UNC ID" & vbCr & "1=first , 2=2nd, etc., folders in to add as tags." _ & vbCr & "(Typ. 1)", _ "OPTIONAL Limits depth/number of subfolders returned as tags." _ & vbCr & "(Typ. 3)", _ "OPTIONAL Delimeters to split tags into more tags" _ & vbCr & "( default = " & vbqt & "\" & vbqt & ")" _ & vbCr & "( alternate = " & vbqt & "\/_ ," & vbqt & " tag at slashes, _, commas, and spaces)" _ ), _ True, "Avail" _ ) End Sub ''------------------------------------------------- ''generat keys for checklist include/exclude Private Function AVAIL_FolderKeys(Optional IndexStart As Integer = 0, Optional IndexDeep As Integer = -1) ''strValue As String, Optional Split_ As Boolean = False) As String ''Add unique in alpha order Attribute AVAIL_FolderKeys.VB_Description = "Uses the 'AVAIL_FolderKeys' tab to create a 'AVAIL_FolderKeys' tabel to list all generated 'AVAIL_FolderKeys' for reference." Attribute AVAIL_FolderKeys.VB_ProcData.VB_Invoke_Func = " \n5" ''find "Filepath" in 1st table Dim ws As Worksheet ''Current towrksheet Dim LI As ListObject ''Table object Dim rng As Range ''range iteration for concatenate Dim x As Variant ''Vairaint for SPLIT Dim newUB As Integer ''New Ubound Dim i As Integer ''Gneric counter Dim str As String ''temp string Dim strCat As String ''concat string Dim preCalc As Integer ''precalc setting Set ws = ActiveWorkbook ''ThisWorkbook.Worksheets(1) ''set current WS - one per Excel file for AVAIL export Dim r, c As Integer ''Initialize content as a table for easy reference, or get table reference If ws.ListObjects.Count = 0 Then r = ws.Range("A1").End(xlDown).Row c = ws.Range("A1").End(xlToRight).Column ws.Range("A1").Select Set LI = ActiveSheet.ListObjects.Add(xlSrcRange, ws.Range(ws.Range("A1"), Cells(r, c))) LI.Name = ws.Name Else Set LI = ws.ListObjects(1) ''Get table reference End If For Each rng In LI.ListColumns("Filepath").DataBodyRange ''Modify/clean/purge string in range value path str = rng.Value ''Underscors to single underscores Do While InStr(1, str, "__", vbTextCompare) > 1 ''while __ exists... str = Replace(str, "__", "_", Start:=1, Count:=-1, compare:=vbTextCompare) Loop ''Replace underscores with "\" ''str = Replace(str, "_", "\", Start:=1, Count:=-1, compare:=vbTextCompare) ''repalce double \\ ''str = Replace(str, "\\", "\", Start:=1, Count:=-1, compare:=vbTextCompare) x = Split(str, "\") ''split on "\" newUB = UBound(x) ''remove drive ''For j = 1 To UBound(x): x(j - 1) = x(j): Next j: newUB = newUB - 1 ''Remove file newUB = newUB - 1 ''Remove last item in path(i.e. filename) ReDim Preserve x(newUB) For i = 0 To newUB ''iterate list and clean Select Case x(i) Case "." ''do nothing Case "\" ''do nothing Case Else strCat = strCat & Trim(x(i)) & "\" End Select Next i Next rng ''<<<<<<<<<<<<<<<<<DEBUG- Get list of all filepaths and feed it to AVAIL_FolderTags to get consolidated value of all tags) ''<<<<<<<<<<<<<<<<<<< MsgBox "Need to rework each search to return keys for EACH LINE i.l.o. the tntire string to get folder limiters working correctly." & vbCr & vbCr & "EXITING.", vbOKOnly + vbCritical, "Exiting" Exit Function str = AVAIL_FolderTags(strCat, IndexStart, IndexDeep) x = Split(str, "|") ''MsgBox "Need to implement creation of 'AVAIL_FolderKeys' workseet and table", vbOKOnly + vbCritical Set ws = ThisWorkbook.Worksheets("AVAIL_FolderKeys") ws.Activate Set LI = ws.ListObjects("AVAIL_FolderKeys") With Application .EnableEvents = False ''disable events/functions preCalc = .Calculation .Calculation = xlCalculationManual End With ' Clear existing data in the table (modify as needed) If Not LI.DataBodyRange Is Nothing Then LI.DataBodyRange.Clear LI.DataBodyRange.Rows.Delete End If ''On Error GoTo AVAIL_FolderKeysEnd ' Loop through the array and add each element to the table For i = LBound(x) To UBound(x) LI.ListRows.Add ''push array into table LI.DataBodyRange.Cells(i + 1, 1).Value = x(i) Next i ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< AVAIL_FolderKeysEnd: With Application .EnableEvents = True ''disable events/functions .Calculation = preCalc End With ws.Calculate End Function ''------------------------------------------------- Private Sub testAVAIL_FolderTags() ''ReDim Preserve AF(0) ''initialize array Debug.Print AVAIL_FolderTags("A\d\b\c\g\f\e\a") End Sub ''-------------------------------------------------- Function AVAIL_FolderTags( _ strFilePath As String, _ Optional IndexStart As Integer = 0, _ Optional IndexDeep As Integer = -1, _ Optional Delims As String = "\") _ As String Dim x As Variant ''Continer for split Dim i As Integer ''counter Dim j As Integer ''counter Dim temp As String ''temp swap ''PATHS SECTION to limit path sections based on parameters ''split delim if path first and resolve thepth then reintegrate and check other delims and split again. strFilePath = Replace(strFilePath, "/", "\", compare:=vbTextCompare) ''Treat all slashes the same Do While InStr(1, strFilePath, "\\") ''Remove double delimeters e.g volumes, HTTP, URL, etc strFilePath = Replace(strFilePath, "\\", "\", compare:=vbTextCompare) Loop If InStr(1, Delims, "\") > 0 And InStr(1, strFilePath, "\") > 0 Then x = Split(strFilePath, "\") ''split on file paths to resolve depth If x(UBound(x)) Like "*.???" Or x(UBound(x)) Like "*.????" Then ''file at end - remove. ReDim Preserve x(UBound(x) - 1) ''strip off file name End If If IndexStart > UBound(x) Then ''if start exceeds lenght - nothing to return... AVAIL_FolderTags = "" ''beyond depth of folder structure Exit Function ''IndexStart = UBound(X) ''alternate return parent folder End If If IndexStart > 0 Then ''shift array left ''If start was specified above 0 then we need to shift For i = 0 To UBound(x) - IndexStart ''move starting considerations to 0 position x(i) = x(i + IndexStart) ''shift to 0 from index start Next i ReDim Preserve x(UBound(x) - IndexStart) ''Truncate repeat values from top End If IndexDeep = IndexDeep - 1 ''reset to base 0 array reference If IndexDeep > -1 And UBound(x) > (IndexDeep) Then ReDim Preserve x(IndexDeep) ''truncate unused path depths if indexDeep < elements End If strFilePath = "" ''Reset to refill For i = 0 To UBound(x) ''Reintergrate strFilePath = strFilePath & x(i) & "|" Next i strFilePath = Left(strFilePath, Len(strFilePath) - 1) ''Remove trailing "|" Set x = Nothing ''Cear X() use strFilePath moving to next check End If ''with remaining strFilePath break along additional delimeters If Len(Delims) > 1 Then ''Additional tag breaks For i = 1 To Len(Delims) ''replace each delimiter with "|" to use for split strFilePath = Replace(strFilePath, Mid(Delims, i, 1), "|", compare:=vbTextCompare) Next i Do While InStr(1, strFilePath, "||") > 0 ''While double delimeters exist strFilePath = Replace(strFilePath, "||", "|", compare:=vbTextCompare) ''replace with singles Loop End If strFilePath = Trim(strFilePath) ''clean spaces form ends If InStr(1, strFilePath, "|") = 0 And Len(strFilePath) = 0 Then ''if no delimeters, no text, invalid tag, return nothing AVAIL_FolderTags = "" Exit Function End If ''''''''''''''''''''''''''''''''''''' ''check for duplicate tags and sort'' x = Split(strFilePath, "|") ''ReDim Preserve X(5): X(5) = X(0) & "foo": X(4) = X(1): X(3) = X(2)''<<<DEBUG Repeats ''Null Duplicates For i = LBound(x) To UBound(x) - 1 For j = i + 1 To UBound(x) If x(i) = x(j) Then x(j) = "" ''delete one tag End If Next j Next i For i = LBound(x) To UBound(x) - 1 '' Bubble sort "", Z-A For j = i + 1 To UBound(x) If x(i) < x(j) Then ' Swap elements if they are in the wrong order temp = x(i) x(i) = x(j) x(j) = temp End If Next j Next i For i = UBound(x) To LBound(x) Step -1 '' Bubble sort "", Z-A If x(i) > "" Then If i < UBound(x) Then ReDim Preserve x(i) Exit For End If Next i For i = LBound(x) To UBound(x) - 1 '' Bubble sort A-Z For j = i + 1 To UBound(x) If x(i) > x(j) Then ' Swap elements if they are in the wrong order temp = x(i) x(i) = x(j) x(j) = temp End If Next j Next i For i = 0 To UBound(x) ''Assemble tag If Trim(x(i)) > "" Then AVAIL_FolderTags = AVAIL_FolderTags & Trim(x(i) & "|") End If Next i If Right(AVAIL_FolderTags, 1) = "|" Then AVAIL_FolderTags = Left(AVAIL_FolderTags, Len(AVAIL_FolderTags) - 1) ''strip trailing "|" End If End Function Private Function AVAIL_Tag_Remove(strCSVremove As String, strTags As String) As String Dim AF() As String ''array of folders ReDim Preserve AF(0) ''initialize Dim x, xi, afi, xiStart, j '' If AF(0) = "" Then AF(0) = x(0) ''start null fill xiStart = 1 End If For xi = xiStart To UBound(x) ''items to add ''A-Z sort order For afi = 0 To UBound(AF) ''items to compare ''skip adding if criteria... ''SKIPPING If LCase(x(xi)) = LCase(AF(afi)) _ Or LCase(x(xi)) Like "*macos*" Then ''Stop Exit For End If If LCase(x(xi)) < LCase(AF(afi)) Then ''found spot in list ReDim Preserve AF(UBound(AF) + 1) ''add spot For j = UBound(AF) To afi + 1 Step -1 ''set last to next to last AF(j) = AF(j - 1) Next j AF(j) = x(xi) Exit For ElseIf afi = UBound(AF) Then ReDim Preserve AF(UBound(AF) + 1) ''add spot AF(UBound(AF)) = x(xi) End If Next afi Next xi End Function Private Sub AVAIL_FolderTagsList() ''create a path key table ''populate it with all elements from the file paths for editing ''check if key already in there - if not add it End Sub