I created a UserForm where my team can select the type of report they need, "Condizione di Pericolo" / "Mancato Infortunio" / "Infortunio".
This selection is stored in the variable evento.
After that, I want the file to create and save a copy of the report in a folder based on the report selected.
In SharePoint I have folders "Condizione di Pericolo" / "Mancato Infortunio" / "Infortunio".
The name of the file is standard and based on the date and the name of the user.
There is the possibility that someone makes the same report twice or more in the same day.
I don't want anything to be overwritten, that is why I'm trying to check if in the correct folder there is a file with the same name. If there is, I want the new one to add a suffix like (1) (just like when we make a copy of a file).
Sub SaveReport()
Const path As String = "https://SharePointPath/Main%20Folder/"
Dim i As Long
Dim Saved As Boolean
i = 1
Saved = False
evento = "Condizione di Pericolo" ' Just to test the code
Sheets("Modulo19").Activate ' Redondant, now I know!
ActiveSheet.Copy
If evento = "Condizione di Pericolo" Then
' filename = path + nome del file + estensione
filename = path & "/" & "Condizione%20di%20Pericolo" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
' Check to see if the file exist
If Len(Dir(filename)) = "" Then
ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
Call GeneraReport
Exit Sub
Else
End If
' If it exist, let's use another name
Do While Saved = False
If Len(Dir(filename)) <> "" Then
filename = path & "/" & "Condizione%20di%20Pericolo" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "_(" & i & ")" & ".xlsx"
ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
Saved = True
Call GeneraReport
Else
i = i + 1
End If
Loop
' From now on is just the same code repeating...
ElseIf evento = "Mancato Infortunio" Then
filename = path & "/" & "Mancato%20Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
If FileExist(filename) = False Then
ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
Call GeneraReport
Exit Sub
Else
End If
Do While Saved = False
If FileExist(filename) = False Then
filename = path & "/" & "Mancato%20Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "_(" & i & ")" & ".xlsx"
ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
Saved = True
Call GeneraReport
Else
i = i + 1
End If
Loop
ElseIf evento = "Infortunio" Then
filename = path & "/" & "Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
If FileExist(filename) = False Then
ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
Call GeneraReport
Exit Sub
Else
End If
Do While Saved = False
If FileExist(filename) = False Then
filename = path & "/" & "Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "_(" & i & ")" & ".xlsx"
ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
Saved = True
Call GeneraReport
Else
i = i + 1
End If
Loop
End If
End Sub
The forward slash / is not a problem for the SaveAs command. I use it in other files.
Right now, I have the problem with the Dir command.
I have this error:
Run-time error '52': Bad file name or number
Run-time error '52': Bad file name or number
I also use this Function called FileExist found on the internet.
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
In this case I always get Empty as result, so for the Function I do not have a file with the same name and it overwrites it.
(Previous response from when we were discussing local paths...)
Here's a simpler version (edit: per FunThomas's answer, forward slashes should be backslashes):
Sub SalvaReport()
Const path As String = "C:\SharePointDirectory\SharePoint%20Folder\"
Dim i As Long, fnTemplate As String, fldr As String, fileName As String, evento As String
i = 0
evento = "Condizione di Pericolo" ' etc
fldr = Replace(evento, " ", "%20") 'replace spaces with %20
'File name template: `{tmp}` is a token to be replaced...
fnTemplate = path & "\" & fldr & "\" & _
Format(Now(), "dd-mm-yyyy") & "_" & _
Split(Application.UserName, " ")(1) & "{tmp}.xlsx"
fileName = Replace(fnTemplate, "{tmp}", "") 'start with no counter
Do While Len(Dir(fileName, vbNormal)) = 0 'file exists?
i = i + 1
fileName = Replace(fnTemplate, "{tmp}", "(" & i & ")") 'add counter
Loop
ThisWorkbook.Worksheets("Modulo19").Copy ' Copio l'intera sheets "Modulo19"
ActiveWorkbook.SaveAs fileName, FileFormat:=xlOpenXMLWorkbook
GeneraReport 'no need for `Call`
End Sub
Added after it was clear you're looking for something to check for files over HTTP[S] (where Dir() won't work)...
You can use ADO to query a SharePoint List/Library - see example code below. You could use this as a basis for finding if a given filename already exists.
Sub ListSPLibraryFiles()
'## Add a VBA project reference to the ADO object library ##
Const SERVERUrl As String = "https://contoso.sharepoint.com/sites/ABCSite/"
Const ListName As String = "{f82ace17-b0c2-48b4-aa1c-b5d93ddb0c35}" 'List/Library *GUID*
Dim Conn As New ADODB.Connection, rs As ADODB.Recordset
Dim sql As String, objWksheet As Worksheet
With Conn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" & _
"DATABASE=" & SERVERUrl & ";" & _
"LIST=" & ListName & ";"
.Open ' Open the connection
End With
'query all library records for xlsx docs
sql = "SELECT * FROM [" & ListName & "] where [Content Type]='Document' and [File Type]='xlsx'"
Set rs = New ADODB.Recordset
rs.Open sql, Conn, adOpenStatic
PutToSheet rs, ThisWorkbook.Worksheets("Results") 'display the results
rs.Close
Conn.Close
End Sub
'load field names and data from `rs` to worksheet `ws`
Sub PutToSheet(rs As ADODB.Recordset, ws As Worksheet)
Dim f As ADODB.Field, i As Long
With ws
.Cells.Clear 'clear any previous data
If Not rs.EOF Then
For Each f In rs.Fields
ws.Range("A1").Offset(0, i).Value = f.Name
i = i + 1
Next f
ws.Range("A2").CopyFromRecordset rs
End If
End With
End Sub
Check out what shows up on the "results" sheet and figure out how to use that info to confirm a given path.