AVAIL_Files ©Ron E. Allen 2023

Attribute VB_Name = "AVAIL_Files" Option Explicit Sub AVAIL_TABS_TO_TSVs_Export(Optional Warn As Boolean = True) If Warn Then If MsgBox("Export and overwrite all TSVs in file folder?", vbYesNo + vbCritical + vbQuestion, "OVERWRITE existing TSVs?") <> vbYes Then Exit Sub End If Dim wb As Workbook Dim ws As Worksheet Dim fso As New FileSystemObject ''Include scripting runtime Dim fp As String ''Filepath Dim ofile As File ''iterate files Dim fn As Variant ''Filename Dim found As Boolean ''search files and warn if doe not exits Dim TSVs() As Variant ''file list of TSVs Dim TSVsUB As Integer ''UBound of TSVs Dim ForceExport As Boolean ''force export all anyway Set fso = CreateObject("Scripting.FileSystemObject") ''backup create object and set FSO Set wb = Application.ActiveWorkbook TSVsUB = 0 ''default base if still -1 then none found. If ThisWorkbook.MasterFolder = "" Then ThisWorkbook.RefreshMasters For Each ofile In fso.GetFolder(ThisWorkbook.MasterFolder).Files ''Get file list If LCase(fso.GetExtensionName(ofile)) = "tsv" Then TSVsUB = TSVsUB + 1 ''add one to ubound count ReDim Preserve TSVs(1 To TSVsUB) ''redim array TSVs(TSVsUB) = fso.GetBaseName(ofile) ''set value End If Next ofile If TSVsUB = 0 Then ''warn no existing TSVs If MsgBox( _ "No TSVs appear in the output folder: " _ & vbCr _ & vbCr _ & fp & vbCr _ & vbCr _ & "Export all tabs to TSVs anyway?", _ vbCritical + vbYesNo, _ "No output TSVs found - EXPORT ALL ANYWANY?" _ ) <> vbYes _ Then MsgBox "Exiting - nothing saved", vbOKOnly + vbCritical Exit Sub Else ForceExport = True End If End If ''--------------------------------------------------------- For Each ws In wb.Worksheets found = False ''RESET found to false For Each fn In TSVs() If LCase(fn) = LCase(ws.Name) Then found = True Exit For End If Next fn If Not found And Not ForceExport Then If MsgBox("Tab name not found in target folder- may have been renamed or is old folder, export anyway?", _ vbYesNo + vbQuestion, _ ws.Name & " TAB NOT FOUND IN EXPORT FOLDER." _ ) _ = vbYes Then found = True End If Else Export_TSV ws End If Next ws AVAIL_Files.Save_Workbook End Sub Sub AVAIL_TSVs_TO_TABS_IMPORT() Dim wb As Workbook ''Workbook Reference Dim ws As Worksheet ''Worksheet reference Dim fso As New FileSystemObject ''Include scripting runtime Dim fp As String ''Filepath Dim fn As String ''Filename Dim ofile As File ''iterate files Dim i As Integer ''basic counter Dim preCalc As Integer ''previous calculation setting Dim r As Long ''Generic row Dim c As Long ''generic column Dim dataRange As Range ''Data range of table Dim queryTable As queryTable ''query table object to delete Dim tbl As ListObject ''Tables are list objects Dim iFileCt As Integer ''counts imports Dim rng As Range ''For converting table to tange ''double set FSO as Backup Set fso = CreateObject("Scripting.FileSystemObject") ''backup create object and set FSO Set wb = Application.ActiveWorkbook ''active workbook Application.StatusBar = "SORTING SHEETS" Call SortWorksheetsTabs Application.StatusBar = "SCANNING FILEFOLDER AND UPDATING TSVs" fp = Filepath_Resolve_Local(wb.Path) Application.EnableEvents = False preCalc = Application.Calculation Application.Calculation = xlCalculationManual For Each ofile In fso.GetFolder(fp).Files If LCase(fso.GetExtensionName(ofile)) = "tsv" Then ''compare against tabs in active workbook iFileCt = iFileCt + 1 ''Add count of files brought in Application.StatusBar = "SCANNING FILEFOLDER AND UPDATING TSVs :: " & ofile.Name fn = fso.GetBaseName(ofile) On Error Resume Next: Set ws = Nothing: Set ws = wb.Worksheets(fn): On Error GoTo 0 ''if not found - we need to crete it and pu tit in the right order If ws Is Nothing Then ''Create worksheet On Error Resume Next Set ws = wb.Sheets(fn) On Error GoTo 0 If ws Is Nothing Then Set ws = wb.Worksheets.Add(after:=wb.Worksheets(Worksheets.Count)) ws.Name = fn End If End If ' Clear any data in the sheet ws.Activate Do While ws.ListObjects.Count > 0 ''for any tables in the worksheet With ws.ListObjects(1) Set rng = .Range ''range reference .Unlist ''convert to range End With Loop ws.Cells.Delete ''delete everything to create a new table ''Do While ws.ListObjects.Count > 0: ws.ListObjects(0).Delete: Loop Application.StatusBar = "SCANNING FILEFOLDER AND UPDATING TSVs: Importing TSV" ' Import data from the TSV file Set queryTable = ws.QueryTables.Add(Connection:="TEXT;" & ofile, Destination:=ws.Range("A1")) With queryTable .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .Refresh End With ' Remove the QueryTable to avoid conflicts queryTable.Delete ''would it be better to use query tables outright? ' Define the range of the imported data r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row c = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column Set dataRange = ws.Range(ws.Cells(1, 1), ws.Cells(r, c)) Application.StatusBar = "SCANNING FILEFOLDER AND UPDATING TSVs: Creating table" ' Create a table from the imported data Set tbl = ws.ListObjects.Add(xlSrcRange, dataRange, , xlYes) tbl.Name = fn ' Update with your table name ''Conditionals to add preset formulas as columns to tables here ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ''FormulasAdd(tbl) ''if tbl.name = "foo" then '' tbl.columns.add (Get column name and formula to populate column ''end if ''<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ''Stop ''1. Import tsv to sheet ''2. convert it to a table ''3. check against previous - add formulas to columns as needed End If Next ofile Application.EnableEvents = True Application.Calculation = preCalc Application.StatusBar = "Import complete. " & Format(iFileCt, "0#") & " TSVs Imported." End Sub Sub SortWorksheetsTabs() ''https://trumpexcel.com/sort-worksheets/ Application.ScreenUpdating = False Dim ShCount As Integer, i As Integer, j As Integer ShCount = Sheets.Count For i = 1 To ShCount - 1 For j = i + 1 To ShCount If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then Sheets(j).Move before:=Sheets(i) End If Next j Next i Application.ScreenUpdating = True End Sub Function Filepath_Resolve_Local(fp As String) As String Dim ObjFolders As Object Dim RE As New RegExp ''Regexp Dim strUser As String ''User ID Dim WSHNetwork ''As WSHNetwork Dim xpath As String ''compare with fp xpath = fp Set WSHNetwork = CreateObject("WScript.Network") Set ObjFolders = CreateObject("WScript.Shell").SpecialFolders strUser = CStr(WSHNetwork.UserName) With RE .Pattern = "\/" ''find forward slash to back slash .IgnoreCase = True If .Test(xpath) Then .Global = True xpath = .Replace(xpath, "\") ''replace with back slach End If ''e.g. pathed to sharepoint - attempt relocate local ''https:\\waremalcomb-my.sharepoint.com\personal\rallen_waremalcomb_com\ .Pattern = "https\:\\\\.*?my.sharepoint.com\\personal\\" & strUser & "_waremalcomb_com\\documents\\" If .Test(xpath) Then ''Repalce with local user path xpath = .Replace(xpath, Environ("userprofile") & "\OneDrive - Ware Malcomb\") End If 'Onedrive path '.Pattern = "\\OneDrive .*?\\" '.Global = False '.MultiLine = False 'If RE.Test(xpath) Then ' xpath = RE.Replace(xpath, "\") ''strip out one drive redundant file path 'End If End With Filepath_Resolve_Local = xpath End Function Sub Export_Active_Worksheet_TSV() Dim ws As Worksheet ''for active worksheet Dim strDefaultWBname As String ''default WB Path & Name Dim xpath As String Set ws = Application.ActiveSheet ''active worksheet xpath = Filepath_Resolve_Local(ActiveWorkbook.Path) strDefaultWBname = ActiveWorkbook.Name ''default WB Name Export_TSV ws ''leaves wb in TSV state Application.StatusBar = "Saving XLSM" Save_Workbook End Sub Sub Save_Workbook() With Application .DisplayAlerts = False .EnableEvents = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.MasterFolder & "\" & ThisWorkbook.MasterFilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False .DisplayAlerts = True ''Turn on warning .EnableEvents = True ''Turn on warning End With End Sub Private Sub Export_TSV(ws As Worksheet) ''Try to parse junk getting around the sharepoint and one drive folders to local filepath Dim strDefaultWBname As String ''default WB Path & Name Dim xpath As String strDefaultWBname = ActiveWorkbook.Name ''default WB Name xpath = ActiveWorkbook.Path & "\" ''Path & Filename xpath = Filepath_Resolve_Local(xpath) xpath = StripExtensions(xpath) ''stripFileExtensions Dim y y = ActiveWorkbook.FullName Application.DisplayAlerts = False ''Turn off warning Application.StatusBar = "Saving TSV" ''MANUAL SAVE: ActiveWorkbook.SaveAs Filename:="C:\Users\rallen\OneDrive - Ware Malcomb\Documents\WM-Projects\NON-23-0042-02-Avail\I__Temp_Studio ID Tools__Furniture_9678aa71.txt", FileFormat:=xlText, CreateBackup:=False ''save cuirrent active worksheet Dim fpTSV As String fpTSV = xpath & ws.Name & ".tsv" ChDir xpath ''Change target directory ''ActiveWorkbook.SaveAs Filename:=fpTSV, FileFormat:=xlText, CreateBackup:=False ws.Activate ''Try setting worksheet as current With Application .DisplayAlerts = False .EnableEvents = False ActiveWorkbook.SaveAs Filename:=fpTSV, FileFormat:=xlText, CreateBackup:=False .EnableEvents = True .DisplayAlerts = True ''Turn on warning End With End Sub Function StripExtensions(strPath As String) As String Dim ext Dim X, y If Right(strPath, 1) = "\" Then ''is only filepath as ends in '\' StripExtensions = strPath Exit Function End If ext = Array(".txt", ".xlsm", ".xlsb", ".tsv") For Each y In ext ''loop through each item For Each X In ext If Right(LCase(strPath), Len(X)) = LCase(X) Then strPath = Left(strPath, Len(strPath) - Len(X)) End If Next X Next y StripExtensions = strPath End Function Private Sub testGet_User() GET_USER_COMPUTER End Sub ''''''''''''''''''''''''''' ''Get user login ID Function GET_USER_COMPUTER(Optional retval As Integer) '''1= user '''2=computer '''4=domain '''Add combinations to get variations-i.e.: '''user + computer (3) returns "user@computer" '''User + computer + domain (7) returns "user@computer.domain" Dim WSHNetwork ''As WSHNetwork Set WSHNetwork = CreateObject("WScript.Network") GET_USER_COMPUTER = "" If retval = 0 Then retval = 7 If retval And 1 Then GET_USER_COMPUTER = GET_USER_COMPUTER & CStr(WSHNetwork.UserName) If retval And 2 Or retval And 4 Then GET_USER_COMPUTER = GET_USER_COMPUTER & "@" End If End If If retval And 2 Then GET_USER_COMPUTER = GET_USER_COMPUTER & CStr(WSHNetwork.ComputerName) End If If retval And 4 Then If GET_USER_COMPUTER > "" Then GET_USER_COMPUTER = GET_USER_COMPUTER & "." GET_USER_COMPUTER = GET_USER_COMPUTER & CStr(WSHNetwork.UserDomain) End If End Function