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
Comments
Post a Comment