Need 'Save As' capability in attached VBA script.

waza1
waza1 used Ask the Experts™
on
Hi all, I am currently using the below code to extract data from various sources workbooks, and place into a single destination workbook. Problem is, although a unique name is given (todays date), unfortunately any subsequent files created on the same day are given the same name and are replacing the orginal file. I do not want this to happen, and would like any subsequent files be given the option of either replacing or a save as.  With 'screen updating' on, it sort of works, but when you enter OK, it errors out.  Any assistance given will be appreciated. Many thanks.

Sub SScopy()
Application.ScreenUpdating = False
Range("H6:R6").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd
Range("H6:AY225").Select
Selection.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteColumnWidths
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Range("A1").PasteSpecial xlPasteFormats
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs FileName:="\\Ooc-fls-01\CPSU\CPSU MASTER\New Invoicing\Invoice Batches\" & Format(Date, "yyyy mmmm dd") & ".xls"
ActiveWorkbook.Close
End Sub
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2010

Commented:
Here is one very simple change that guarantees a unique file name, unless you can somehow run the routine more than once in the same second:

ActiveWorkbook.SaveAs FileName:="\\Ooc-fls-01\CPSU\CPSU MASTER\New Invoicing\Invoice Batches\" & Format(Now, "yyyy-mm-dd hh-nn-ss") & ".xls"

Author

Commented:
Great idea, but really need the ability to do a replace or save as.
 Thanks.
Top Expert 2010
Commented:
Sub SScopy()
Dim SaveTo As Variant
Application.ScreenUpdating = False
Range("H6:R6").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd
Range("H6:AY225").Select
Selection.Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteColumnWidths
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Range("A1").PasteSpecial xlPasteFormats
Range("A1").Select
Application.CutCopyMode = False
SaveTo = "\\Ooc-fls-01\CPSU\CPSU MASTER\New Invoicing\Invoice Batches\" & _
    Format(Date, "yyyy mmmm dd") & ".xls"
If Dir(SaveTo) <> "" Then
    SaveTo = Application.GetSaveAsFilename(SaveTo, "Excel workbook (*.xls), *.xls",, _
        "Save the file, dude")
End If
If SaveTo <> False Then
    ActiveWorkbook.SaveAs FileName:=SaveTo
Else
    'do you need to do anything if the user cancels the dialog?
End If
ActiveWorkbook.Close
End Sub

Author

Commented:
Thankyou, thankyou, works like a charm.

Author

Commented:
Almost forgot to forward the grade, sorry for that.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial