Display Current Date With Specific Formatting In Cell Only Once

I have a blank template workbook containing several sheets which gets copied, filled out, and saved many times. One of the sheets in this workbook has a 'Date' cell on it which needs to display the date on which the rest of that sheet gets filled out, but it shouldn't change if the sheet receives changes later on. The format of the date cell should read, for example; Feb 28, 2012.

I've been trying to figure out how to do this, and I think I've got something - one of the other cells on this particular sheet will receive a data entry once, at the 'creation' of a fresh copy of this template. This cell - Cell L3:Q3 - will not be changed at any further time, as most of the other cells may be subject to. My thought is this: Upon the data entry into the L3:Q3 cell, the date cell - AA1:AC1 - would get the current date inserted into it, and wouldn't change again, unless somebody wanted to manually do so.

How could I do this?

In simpler words, I need the current date formatted as Feb 29, 2012 inserted into Cell AA1:AC1 when Cell L3:Q3 receives data.

You could try something like this and amend as required based on the answers to above - place this code into the worksheet where you want this to occur (not into a module) via VB Editor

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("L3:Q3"), Target) Is Nothing Then
Application.EnableEvents = False
Range("AA1:AC1") = Format(Date, "MMMM dd,yyyy")
Application.EnableEvents = True
End If
End Sub

Does there have to be data in every cell from L3 to Q3 before the date is entered into AA1:AC1? or if data just goes into one of the cells in this range? Does the date get entered in all 3 cells AA1:AC1 all at once? Can you be just a little more specific please?

Right click on the sheet tab and paste this onto the code page that appears.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("L3:Q3")) Is Nothing Then Exit Sub
    With Range("AA1:AC1")
        .Value = Date
        .NumberFormat = "mmm dd, yyyy"
    End With

End Sub

Dom

Absolutely, forgive me - Cell AA1:AC1 and Cell L3:Q3 are both merged cells. I considered just saying Cell AA1 and Cell L3 to see if that works, but I figured I should cover all the angles.

Merged cells are nasty but this should do it:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("L3")) Is Nothing Then Exit Sub
    With Range("AA1")
        .Value = Date
        .NumberFormat = "mmm dd, yyyy"
    End With

End Sub

Dom

Thanks! I tried this and this is really cool! I don't know anything about VB code so I have to copy what I can find. I really appreciate the knowledge of others who are willing to share! And it helps me to learn new things, too.

Hmm, I have a bit of a situation here - this works beautifully if I go into Cell L3:Q3 (as nasty as that is) and enter data, thank you Domski, but the way Cell L3:Q3 receives it's data is through the creation of a new workbook. I would upload a sample, but the Internet here has been having upload issues, so I'll try to explain as clearly as possible:

Besides this sheet (called the Process Sheet) there's a Data Entry Sheet. There's others as well but I don't think they're important.

Cell L3:Q3 is linked to Cell B13 on the Data Entry Sheet.

Cell B13 on the Data Entry Sheet receives data when this whole workbook is saved as a number - basically, the number the workbook gets saved as gets transferred into Cell B13 on the Data Entry Sheet.

That number in turn is linked to our awesome Cell L3:Q3.

Basically what happens at this point is that when I save the workbook with Domski's new code in it as a blank (therefore no data is yet in Cell L3:Q3 on the Process Sheet), the date cell is empty - which is awesome, by the way; but when I save the workbook as a new number, open it, and Cell B13 on the Data Entry Sheet now has data, which of course means that Cell L3:Q3 on the Process Sheet has data - Cell AA1:AC1 doesn't display the date.

Does that make sense? And is that easy enough to fix?

Code would change to this and need to go on the Data Entry Sheet's code page.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("B13")) Is Nothing Then Exit Sub
    With Sheets("Process Sheet").Range("AA1")
        .Value = Date
        .NumberFormat = "mmm dd, yyyy"
    End With

End Sub

Dom

Put the change event code behind the Data Entry sheet and monitor B13 rather than your merged (yuck) cells.

What he said

Dom

The same dynamic/process/code that fills Cell B13 could fill L3:Q3

If I can offer you one piece of advice. AVOID MERGED CELLS - instead format the cell and in Alignment tag select Center Across Selection. Merged cells should be avoided as all they do is stuff up worksheets. My 2 cents worth

smuzoen, thank you for your code - it has, unfortunately, the same effect as Domski's. OnErrorGoTo0, thank you for your suggestion, I'd gladly do that but am a bit unsure as how to merge this - without messing anything up: (thanks again Domski)

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("B13")) Is Nothing Then Exit Sub
    With Sheets("Process Sheet").Range("AA1")
        .Value = Date
        .NumberFormat = "mmm dd, yyyy"
    End With

End Sub

..to this code already behind the Data Entry Sheet: (thanks to too many forum members than I can count)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngCell As Range
    Dim rngMonitor As Range
    On Error GoTo err_handle
    
    ' adjust to whatever cells you want to monitor
    Set rngMonitor = Range("B12")
    
  If Not IsValidFileName(ThisWorkbook.Name) Then
        MsgBox "Please save the file as <partnumber>Rev<revision number> before entering data!"
        On Error Resume Next
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
        Exit Sub
    End If
    
    If Not Intersect(Target, Range("B13:J13,B19:C19")) Is Nothing Then
        MsgBox "Do not change the part number or revision number. Save the file as the relevant name and the numbers will change automatically."
        On Error Resume Next
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
        Exit Sub
    End If
    
    If Intersect(Target, rngMonitor) Is Nothing Then Exit Sub
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
     For Each rngCell In Intersect(Target, rngMonitor).Cells
      If Val(rngCell.Text) > 0 Then
        If Len(rngCell.Text) < 4 Then
            rngCell.Value = Right("000" & rngCell.Text, 3) & "0"
        ElseIf Len(rngCell.Text) > 4 Then
            MsgBox "Entry is too long"
            rngCell.ClearContents
        End If
      End If
    Next rngCell
    
    
clean_up:
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Exit Sub
    
err_handle:
    MsgBox Err.Description
    Resume clean_up
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    vOldVal = Target

    If Target.Address = "$B$14" Then
        Application.EnableAutoComplete = False
    Else
        Application.EnableAutoComplete = True
    End If
End Sub

And thank you snb for you suggestion as well, although I think I'd rather go with OnErrorGoTo0's idea - and by the way, your avatar is having trouble loading.

Do you not have a Workbook level Before_Save event adding the filename into B13?

Dom

Whilst I generally disagree with snb's coding style, I totally agree with the approach (though you may as well have it simply populate the date cell directly). It will be simpler than trying to integrate even more code into that change event!

Thank you for your 2 cents worth, smuzoen, I appreciate that and will definitely look at doing any further major workbooks the way you suggest. Trust me when I say that your contempt for merged cells is shared by pretty much every single fellow Excel guru who attempts to assist me with my issues.

GeekGirl123, welcome to the forum and yeah, these guys are great, and brilliant, and they've helped me out time and time again, even when I ask the seemingly-impossible at times. It's amazing what can be done with Excel if you or in most cases someone else knows how.

Domski, I looked for that, and I found it in something called basFunctions:

Option Explicit
Const mcstrTEMPLATE_FILENAME As String = "Blank inspection reports & C of Cs 07"

Function IsValidFileName(strFile As String) As Boolean
    Dim lngPos As Long
    lngPos = InStr(1, strFile, "REV", vbTextCompare)
    IsValidFileName = lngPos > 0 And lngPos < Len(strFile) - 2
End Function
Function GetPartNum(strFile As String) As String
    Dim strTemp As String
    strTemp = CleanFileName(strFile)
    If IsValidFileName(strTemp) Then GetPartNum = CStr(Split(UCase$(strTemp), "REV")(0))
End Function
Function GetRevNum(strFile As String) As String
    Dim strTemp As String
    strTemp = CleanFileName(strFile)
    If IsValidFileName(strTemp) Then GetRevNum = CStr(Split(UCase$(strTemp), "REV")(1))
End Function
Function CleanFileName(strFile As String) As String
    Dim strTemp As String, lngSlash As Long, lngExt As Long
    ' check if we have a file path as well
    lngSlash = InStrRev(strFile, "\")
    If lngSlash > 0 Then
        strTemp = Mid$(strFile, lngSlash + 1)
    Else
        strTemp = strFile
    End If
    ' check if we have an extension
    lngExt = InStr(1, strTemp, ".", vbBinaryCompare)
    If lngExt > 0 Then
        CleanFileName = Left$(strTemp, lngExt - 1)
    Else
        CleanFileName = strTemp
    End If
End Function
Function IsTemplateFile(strFile As String) As Boolean
    IsTemplateFile = StrComp(CleanFileName(strFile), mcstrTEMPLATE_FILENAME, vbTextCompare) = 0
End Function
Sub AddPartInformation(strName As String)
    Dim strPart As String, strRev As String
        ' populate cells
        strPart = GetPartNum(strName)
        strRev = GetRevNum(strName)
        With Sheet6
            .Range("B13:J13").Value = strPart
            .Range("B19:C19").Value = strRev
        End With
End Sub

OnErrorGoTo0, sure! Where on earth do I start, though?

Man, you guys are on fire today, I can scarcely keep up to you all.

If you have a look in your ThisWorkbook module, do you have a Workbook_BeforeSave event routine?

Oh! Yes I do! It's down near the bottom half somewhere:

Option Explicit
Const prnPrev As Boolean = False ' Change to False if no print preview desired.
Dim response As Integer, x As Integer
Private Sub selPages()
    Application.EnableEvents = False
    On Error GoTo erHandle
    If Not nPages > 0 Then
        GoTo erHandle
    Else
        ActiveWindow.SelectedSheets.PrintOut from:=1, _
            To:=nPages, copies:=1, preview:=prnPrev, Collate:=True
        GoTo endSub
    End If
erHandle:
    ActiveWindow.SelectedSheets.PrintOut preview:=prnPrev
endSub:
    On Error GoTo 0
    Application.EnableEvents = True
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim response, toPg As Integer

x = 1
    If ActiveSheet.Name = "Inspection Report" Then
        If IsNumeric(Range("X1").Value) And Range("X1") <> "" Then
            toPg = Range("X1").Value
        Else
            toPg = 0
        End If
        response = Application.Dialogs(xlDialogPrint).Show(2, 1, toPg)
        If x > 1 Then
            Cancel = True
        End If
        x = x + 1
    ElseIf ActiveSheet.Name = "Inspection Report Attachment" Then
        If IsNumeric(Range("P1").Value) And Range("P1") <> "" Then
            toPg = Range("P1").Value
        Else
            toPg = 0
        End If
        response = Application.Dialogs(xlDialogPrint).Show(2, 1, toPg)
        If x > 1 Then
            Cancel = True
        End If
        x = x + 1
    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim strSaveName As String, strPart As String, strRev As String
    Dim varData
    On Error GoTo err_handler
    
    ' cancel default save
    Cancel = True
    
    ' prevent this event being triggered by saves in the code
    Application.EnableEvents = False
    
    ' check if copy being saved
    If SaveAsUI Then
    
        strSaveName = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Macro enabled workbook (*.xlsm), *.xlsm", Title:="Save file")
        If strSaveName <> "False" Then
            If IsValidFileName(strSaveName) Then
                ' populate cells and save
                AddPartInformation strSaveName
                ThisWorkbook.SaveAs strSaveName
            ElseIf IsTemplateFile(strSaveName) Then
                ' template, so just save
                ThisWorkbook.SaveAs strSaveName
            Else
                MsgBox "File name is invalid - must be <part number>Rev<revision number>"
                Exit Sub
            End If
        End If
        
    Else
        ' check it's not the template being saved
        If IsTemplateFile(ThisWorkbook.Name) Then
            ' it's the template so just save.
            ThisWorkbook.Save
        Else
            ' populate cells and save
            AddPartInformation ThisWorkbook.Name
            ThisWorkbook.Save
        End If
    End If ' SaveAsUI
    
clean_up:
    Application.EnableEvents = True
    Exit Sub
err_handler:
    MsgBox Err.Description
    Resume clean_up
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim lngResp As Long
    If Not ThisWorkbook.Saved Then
        ThisWorkbook.Saved = True
        lngResp = MsgBox("Do you wish to save the workbook before closing?", vbYesNo)
        If lngResp = vbYes Then
            With ThisWorkbook
                 .Save
                 .Saved = True
             End With
        End If
    End If
End Sub

Maybe:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim strSaveName As String, strPart As String, strRev As String
    Dim varData
    On Error GoTo err_handler
    
    ' cancel default save
    Cancel = True
    
    ' prevent this event being triggered by saves in the code
    Application.EnableEvents = False
    
    ' check if copy being saved
    If SaveAsUI Then
    
        strSaveName = Application.GetSaveAsFilename(filefilter:="Microsoft Excel Macro enabled workbook (*.xlsm), *.xlsm", Title:="Save file")
        If strSaveName <> "False" Then
            If IsValidFileName(strSaveName) Then
                ' populate cells and save
                AddPartInformation strSaveName
                ThisWorkbook.SaveAs strSaveName
            ElseIf IsTemplateFile(strSaveName) Then
                ' template, so just save
                ThisWorkbook.SaveAs strSaveName
            Else
                MsgBox "File name is invalid - must be <part number>Rev<revision number>"
                Exit Sub
            End If
        End If
        
    Else
        ' check it's not the template being saved
        If IsTemplateFile(ThisWorkbook.Name) Then
            ' it's the template so just save.
            ThisWorkbook.Save
        Else
            ' populate cells and save
            AddPartInformation ThisWorkbook.Name
            With Sheets("Process Sheet").Range("AA1")
                .Value = Date
                .NumberFormat = "mmm dd, yyyy"
            End With
            ThisWorkbook.Save
        End If
    End If ' SaveAsUI
    
clean_up:
    Application.EnableEvents = True
    Exit Sub
err_handler:
    MsgBox Err.Description
    Resume clean_up
End Sub

Dom

Maybe you noticed: there's was a downgrading of this forum on 04-12-2011 (sic !)
The basic forum's functionality hasn't been restored yet.

A lot of code can be an indication of too little conceptualising.

snb, I looked up several of the terms you used in online dictionaries and am still having trouble grasping what you mean.

Thanks Domski, I missed your post earlier on due to all that was going on - that seems to work, as least as far as displaying the date goes, and I've added OnErrorGoTo0's code as well, which doesn't seem to change anything as far as I can tell, but it's in there just in case.

Thanks - but now the date gets updated every time the workbook is saved, which isn't supposed to happen, but rather only the first time that our amazing L3:Q3 received data. Do you guys know what I mean?

You can check if the cell is empty like this:

        ' check it's not the template being saved
        If IsTemplateFile(ThisWorkbook.Name) Then
            ' it's the template so just save.
            ThisWorkbook.Save
        Else
            ' populate cells and save
            AddPartInformation ThisWorkbook.Name
            With Sheets("Process Sheet").Range("AA1")
                If .Value = "" Then 
                      .Value = Date
                      .NumberFormat = "mmm dd, yyyy"
               End IF
            End With
            ThisWorkbook.Save
        End If

Make sure you're only doing it in either the event or the AddPartInformation code though.

Dom

Thanks again, but I'm still getting the current date every time I hit save. Which cell is your last bit of code checking?

Okay, I've decided to go with a cell that isn't linked to the filename; I think that'll make things easier.

Merged Cell L4:Q4 isn't linked to the filename, but will receive data via the Data Entry Sheet. I've tried to use this code:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("L4")) Is Nothing Then Exit Sub
    With Range("AA1")
        .Value = Date
        .NumberFormat = "mmm dd, yyyy"
    End With

End Sub

..on the Process Sheet, but since Cell L4:Q4 is linked to the Data Entry Sheet, Cell AA1:AC1 doesn't recognize when data is in Cell L4:Q4.

Maybe I can merge the above code to the Data Entry code, but I haven't had any success so far.

The code I posted checks cell AA1 on the Process sheet and only puts the date in if it's empty. You need to make sure you haven't added code any where else that it going to do the same thing.

Dom

Okay, I made sure that your code:

' check it's not the template being saved
        If IsTemplateFile(ThisWorkbook.Name) Then
            ' it's the template so just save.
            ThisWorkbook.Save
        Else
            ' populate cells and save
            AddPartInformation ThisWorkbook.Name
            With Sheets("Process Sheet").Range("AA1")
                If .Value = "" Then 
                      .Value = Date
                      .NumberFormat = "mmm dd, yyyy"
               End IF
            End With
            ThisWorkbook.Save
        End If

..is the only one associated with the Date Cell. I've deleted the date from the Date Cell on the Process Sheet, and can't get the current date to enter for the life of me. Is there no way that this code:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, Range("L4")) Is Nothing Then Exit Sub
    With Range("AA1")
        .Value = Date
        .NumberFormat = "mmm dd, yyyy"
    End With

End Sub

..can't somehow be modified to work from the Process Sheet?

I'm glad you didn't post a sample workbook; the thread would have been solved too quickly.....

It doesn't matter where you put this.

if cells(1,27)="" then cells(1,27)=date

Lol, thanks snb. I would have done that a long time ago, but I'm unable to upload any sample worksheets for some reason - probably the Internet here, which is a bother indeed. Hopefully it will be fixed soon. Thank you for your code - but how on earth do I use it? Like this?

Private Sub Worksheet_Change(ByVal Target As Range)

   If Cells(1, 27) = "" Then Cells(1, 27) = Date
    End With

End Sub

And Domski, hang on! I think we've got something here. My macros weren't running for some reason - I closed and re-opened Excel and upon saving, the empty Date Cell gets filled with the current date, in the right format! And if I change the date of my computer and hit save in the workbook again, it keeps the previous date, perfect.

The issue now is that the empty Date Cell only gets the current date when the user hits Save. Usually the workbook isn't saved until all the cells are filled in, which kind of defeats the purpose of our efforts.

Private Sub Workbook_Open()
  If sheets("...").Cells(1, 27) = "" Then sheets("...").Cells(1, 27) = Date
End Sub

snb, I am having great difficulty in figuring out how to make your code work. I'm trying to get on the upload issue here so I can post a sample workbook.

Okay finally, a sample workbook. I really hope this helps.

cfr. the attachment
I introduced a stop in the workbook_open procedure so you can see what happens.

WAAA-HOO!! snb, you are like an invisible... ghost - that does good things. Thank you so much! I had no idea that you could do a Cell(1, 27) thing. It works better than I had originally imagined, checking if the Date Cell was empty upon opening the workbook and if so popping in the current date. That is so cool. Sweet. Thanks again!

I'm going to mark this thread as solved, because it finally is. There is another issue I've noticed which is quite the culprit - if you close that workbook I uploaded without saving changes first, a message pops up asking if you'd like to save - if you say Yes, I just noticed, it doesn't. If you are able to have a look at that I'd greatly appreciate it. If not, I'll make a new thread. Thanks so much again to all involved!

I would remove the whole BeforeSave procedure and use this one instead:

Private Sub Workbook_Open()
  with Sheets("Process Sheet")
    If .Cells(1, 27) = "" Then .Cells(1, 27) = Date
    If .Cells(13, 2) <> "" Then ThisWorkbook.SaveAs ThisWorkbook.Path & .Cells(13, 2) & .Cells(19, 2) + 1 & ".xlsm", ThisWorkbook.FileFormat
  end with
End Sub

Thanks yet again snb.. but this seems to wreck my code where it used to display the filename as a part and revision number.

I don't think it is.
You'll have reconceptualize this procedure:
if it's a 'new' sheet it needs a 'creation date' and at the same time it will be renamed with a new version name.
No need to let the user interfere where your code can handle this independently.

Private Sub Workbook_Open()
  with Sheets("Process Sheet")
    If .Cells(1, 27) = "" Then
        .Cells(1, 27) = Date
        .Cells(19, 2)=.Cells(19, 2) + 1
        ThisWorkbook.SaveAs ThisWorkbook.Path & "\" .Cells(13, 2) & " Rev" & .Cells(19, 2) & ".xlsm", ThisWorkbook.FileFormat
   end if
  end with
End Sub

Thanks again snb, I've attached the workbook as we have it thus far...

When I change the filename on the desktop to Blank Workbook, or even 888-888 Rev88, I get the following error upon opening it:

Compile error:

Syntax error

Also, when I 'Save As' the workbook, as a number like 555-555 Rev55, the name doesn't reflect in the appropriate cells on the Data Entry Page. You could check this to see how I got the code in the first place.

Any thoughts?