Save excel workbook with certain tag

[gazmoz17]

Hi,

Not sure if this is VBA solutiion or maybe autohotkey...or both

No way of distinguishing in my file explorer what excel workbooks have connections/queries (Power Query) and which dont.

Therefore, want to start saving new workbooks containing a query with a "Q" tag. I can then filter on Tag "Q" in my file explorer.

Rather than manually adding the tag can F12 (save as) behave differently if a query/connection exists and automatically assign the "Q" tag? If no connection then just standard Save as.

Many Thanks
Gareth

 

[ranman256]

put the code into a module,
then add the SaveAsQfile() to the QuickAccess Toolbar for users to saveAs

Public Sub SaveAsQfile()
Dim vFile, vDir

vDir = getMyDocs()
vFile = vDir & ActiveWorkbook.Name

If HasConnection() Then
  vFile = vFile & "_Q.xlsx"
  ActiveWorkbook.SaveAs vFile
Else
  vFile = vFile & ".xlsx"
  ActiveWorkbook.SaveAs vFile
End If
MsgBox "Saved"
End Sub

private Function HasConnection() As Boolean
HasConnection = ActiveWorkbook.Connections.Count > 0
End Function

private Function getMyDocs()
On Error GoTo errDocs
getMyDocs = Environ$("USERPROFILE") & "\Documents\"
End Function

 

[gazmoz17]

Hi ranman,

Thanks for this much appreciated

Im getting an error message per the attached image.

Do I need to change this line to my actual userprofile:

getMyDocs = Environ$("USERPROFILE") & "\Documents\"

Also will this work irrespective if I have Queries but not connections and vice versa. For either Query or Connection I wish to tag with "Q"

Many Thanks

 

[ranman256]

swap out the MyDocs with:

Public Function getMyDocs()
Dim vDir, vUsr

On Error GoTo errDocs
vUsr = Environ("UserProfile")
vDir = vUsr & "\Documents\"
If Not DirExists(vDir) Then
    vDir = vUsr & "\My Documents\"
    If Not DirExists(vDir) Then
       vDir = "c:\temp"
       MakeDir vDir
    End If
End If
getMyDocs = vDir
Exit Function
errDocs:
MsgBox "Cannot find temp folder", vbInformation, "getMyDocs():" & Err
End Function

Public Function DirExists(ByVal pvDir) As Boolean
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
DirExists = fso.FolderExists(pvDir)
Set fso = Nothing
End Function

Public Sub MakeDir(ByVal pvDir)
Dim fso
On Error GoTo errMake
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(pvDir) Then fso.CreateFolder pvDir     'MkDir pvDir
Set fso = Nothing
Exit Sub
errMake:
'MsgBox Err.Description & vbCrLf & pvDir, , "MakeDir(): " & Err
Set fso = Nothing
End Sub