Need Prompt to Not Overwrite Files (1 Viewer)

[pastelrain]

Hi,

Users may want to filter on different selections and want to save several of these reports, so I am needing a way to not have my code attempt to overwrite or modify the existing file. I would need to also apply the formatting to whatever the secondary file name would be. Can someone please help? Below is what I currently have:

Sub Command34_Click()
On Error Resume Next
Dim Filename As String
Dim month1 As String
Dim year1 As Integer

Dim startTime As Date
startTime = Now

Dim strDirectoryPath As String
strDirectoryPath = "U:\Desktop" '& Format$(Now(), "yyyy-mm-dd") ' & "\"

Filename = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & ".xls"
DoCmd.OpenQuery "QI_GAP_REPORT_FOR_EXCEL"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "QI_GAP_REPORT_FOR_EXCEL", Filename, False, "Summary"
DoCmd.Close acQuery, "QI_GAP_REPORT_FOR_EXCEL"

'///****Format excel workbook****////
'Late binding to avoid reference:
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Workbook
Dim xlWS As Object 'Worksheet
Dim GetBook As String
Dim tbl As ListObject
Dim rng As Range



' Create the instance of Excel that we will use to open the temp book
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open(Filename)
Set xlWS = xlWB.Worksheets("Summary")


' Format our temp sheet
' ***************************************************************************

xlApp.Range("A1").Select

Const xlLandscape As Long = 2
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Const xlContext As Integer = -5002
Const xlDown As Integer = -4121
Const xlContinuous As Integer = 1
Const xlThin As Integer = 2


With xlWS
With .UsedRange
.borders.LineStyle = xlContinuous
.borders.ColorIndex = 0
.borders.TintAndShade = 0
.borders.Weight = xlThin
End With

'format header 90 degree
With .Range("i1:y1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.UsedRange.Rows.RowHeight = 15
.UsedRange.Columns.AutoFit
With xlWB.Sheets("Summary")
Set rng = .Cells(1, 1).CurrentRegion
End With


'With xlWS
'Set rng = xlWS.Range(Range("A1"), xlWS.Range("A1").SpecialCells(xlLastCell))
Set tbl = xlWS.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
tbl.ShowTotals = True
'End With

'Disclaimer

Call .Range("A1:A10").EntireRow.insert
.Cells(1, 1).Value = "HEDIS 2017"
.Cells(2, 1).Value = "Part-C claims through June 30, 2016"
.Cells(3, 1).Value = "HbA1c Test Dates and Results as of June 30, 2016"
.Cells(4, 1).Value = "DRE Dates as of June 30, 2016"
.Cells(5, 1).Value = "OMW Due Dates & MRP Discharge Dates as of June 30, 2016" 'same as Part-C date
.Cells(7, 1).Value = "The information contained in this report is intended only for the person or entity to which it is addressed and may contain CONFIDENTIAL material. If you receive this material/information in error, please contact your Account Executive and destroy the material/information."
.Cells(8, 1).Value = "Disclaimer - The information contained in this report is not a medical report, nor is it intended to be a complete record of a patient's health information."
.Cells(9, 1).Value = "Certain information may have been intentionally excluded and the report may also contain errors. Physicians must use their professional judgment to verify this information and should not exclusively rely on this information to treat their patients."
.Cells(10, 1).Value = "Users of this report must take appropriate steps to safeguard the information contained within this report."

'Format
.Range("A1:A7").Font.Bold = True
.Range("A8:A10").Font.Italic = True
.Range("a11").EntireRow.AutoFit

With .UsedRange.Font
.Name = "Arial"
.Size = 9
End With

.Range("A1").Font.Size = 12

With .Range("A11:AE11")
'.Interior.ColorIndex = 35
.Font.Bold = True
.borders.LineStyle = xlContinuous
.borders.ColorIndex = 0
.borders.TintAndShade = 0
.borders.Weight = xlThin
End With

End With

With xlWS.PageSetup
.PrintHeadings = False
.PrintGridlines = False
.Orientation = xlLandscape
.Draft = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False ' this used to be 0 on previous printers but False works on the new Xerox
.PrintTitleRows = "$1:$11"
End With
'xlWS.Range("A12").Select
'xlWB.ActiveWindow.FreezePanes = True

xlWS.Columns("I:Y").AutoFit
xlWS.Range("A1").Select


'Save the file and close it /sua
'xlApp.Visible = True
xlWB.Save
xlApp.Application.Quit
'xlWB.Close


MsgBox "A copy of the report has been saved to your 'U:' drive desktop folder."
'SubExit:
' On Error Resume Next
' DoCmd.Hourglass False

'SubError:
' MsgBox "Error Number: " & Err.Number & "- " & Err.Description, vbCritical + vbOKOnly, "An error occured"
' GoTo SubExit
End Sub

 

[sneuberg]

Maybe you could use the Dir function to see if the file exist and if it does then modify the name somehow like below I add a "_1"

If Len(Dir(strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & ".xls")) = 0 Then
    'no existing file
    FileName = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & ".xls"
Else
    'file exists
    FileName = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & "_1.xls"
End If

or you could use the follow function which give the user a file dialog in which the file name could be change if it exists.

Public Function SaveFile(strInitialFileName As String) As String
 
Dim dlgSaveAs As FileDialog
Dim strSelectedFile As Variant
'will return empty string if canceled
SaveFile = ""
'Set the dialog type
Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
'Display the dialog
dlgSaveAs.InitialFileName = strInitialFileName
dlgSaveAs.AllowMultiSelect = False
dlgSaveAs.Show
'can only be one a allowmultiselect is false
For Each strSelectedFile In dlgSaveAs.SelectedItems
    SaveFile = strSelectedFile
Next
Set dlgSaveAs = Nothing
 
End Function

 

[pastelrain]

Thanks, sneuberg. I believe I was able to do this, but the instance of excel that does the formatting isn't able to find the new file name since this line of code is still looking for the first filename:

Set xlWB = xlApp.Workbooks.Open(Filename).

Do you know how I can create two (or even more) possible filenames, but also have them formatted the way I need them?

 

[sneuberg]

By the time it gets to the line

Set xlWB = xlApp.Workbooks.Open(Filename)

the filename is the file name created by

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "QI_GAP_REPORT_FOR_EXCEL", Filename, False, "Summary"

which either has a "_1" on it or not. I don't understand how it can't find it. Did you actually try this code.

If Len(Dir(strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & ".xls")) = 0 Then
    'no existing file
    FileName = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & ".xls"
Else
    'file exists
    FileName = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & "_1.xls"
End If

Note that it establishes the file name before it is created by DoCmd.TransferSpreadsheet.

The code I suggested could use a lot of improvement as it's only good for one shot, i.e., if "_1" exists then it should go to "_2" etc, but it should work.

 

[sneuberg]

A simple way to avoid overwrite files would be to extend the file name by change the line:

Filename = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy") & ".xls"

to

Filename = strDirectoryPath & "\" & "QI_GAP_REPORT_ " & Format$(Now(), "mm-dd-yyyy-hh-mm-ss") & ".xls"

By including the time down to the second in the filename you would be pretty sure that they were unique.

 

[pastelrain]

Awesome, I think that will do it! Thanks