Vba needed: Saving over orginial file

bamaisgreat

Well-known Member
Joined
Jan 23, 2012
Messages
792
I have a macro that saves my workbook as the current date and time. After that a different user opens the workbook and runs a macro that saves it,keeping the date and time as the first macro and then adds some additional text to the file name. The problem i have is that I now have 2 files that are identical but with different file names. I need the first one to be saved over or deleted. The code below is the 2nd macro that is used...

Code:
Sub FINALIZED_BY_QC()

Dim newFileName As String
Dim appendText As String
Dim pass As String
pass = "bama"  'Change this to whatever your password needs to be
If Not InputBox("Enter Password", "Password") = pass Then Exit Sub
With ActiveSheet
.Unprotect
With .Range("J24").Interior
.Pattern = xlSolid
.PatternColorIndex = 1
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
appendText = "-FINALIZED BY QC"
.Range("J24").FormulaR1C1 = appendText

    Range("A1:U23").Select
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = "$A$1:$U$23"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&Z&F&F&D&T"
        .LeftMargin = Application.InchesToPoints(1)
        .RightMargin = Application.InchesToPoints(0.45)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = False
        .PrintQuality = 300
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaper11x17
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = True
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = False
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    Application.Dialogs(xlDialogPrinterSetup).Show
    ActiveSheet.PageSetup.PrintArea = "$A$1:$U$23"
    
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        
    
    
.UsedRange.Locked = True
.Protect Password:="1288", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
newFileName = Left(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, ".xls") - 1) & appendText
ActiveWorkbook.Save Filename:=newFileName, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Save
End Sub
 

Jerry Sullivan

MrExcel MVP
Joined
Mar 18, 2010
Messages
8,787
Try replacing this part of your code:
Code:
newFileName = Left(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, ".xls") - 1) & appendText
ActiveWorkbook.Save Filename:=newFileName, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Save
With this...
Code:
With ActiveWorkbook
    oldFileName = .FullName
    newFileName = Left(.FullName, InStrRev(.FullName, ".xls") - 1) _
        & appendtext
    .SaveAs Filename:=newFileName
End With
Kill oldFileName
 

Forum statistics

Threads
1,081,727
Messages
5,360,910
Members
400,602
Latest member
newaqua

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top