Macro for prompting date entry

**Armored Wing** · 01-13-2012, 12:15 PM

Hi all, I need to create a condition in which a input prompt pops up for date entry.

I have two problems currently present in my spreadsheet. The first one is that i need to have the message of the equation

=IF(AND(F10="Pending",M1="Pending"), "Please Enter Date", "")

displayed in the cell upon fulfilling the condition followed by the prompting of entry of the date.

The second problem I currently face is that I can't seem to get the date format to display in the input box as it only displays numbers.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     
    Dim Rng1            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim Date1       As Long
    
     
    Set Rng1 = Me.Range("A1:A50")
    If Intersect(Target(1, 1), Rng1) Is Nothing Then
        Exit Sub
    End If
    Cancel = True
    On Error Resume Next
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    Date1 = InputBox(Prompt, Title)
     
    
     
    If Err <> 0 Then
        On Error GoTo 0
        Exit Sub
    End If
    On Error GoTo 0
     
    Target(1, 1).NumberFormat = "@"
    Target(1, 1).Value = Date1 & ""
     
End Sub

If anyone could provide some help to where I went wrong, that would be greatly appreciated.

**Kelshaer** · 01-13-2012, 12:35 PM

Your first problem is not clearly described.
For Your second problem use the following code instead

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     
    Dim Rng1            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
     
    Set Rng1 = Me.Range("A1:A50")
    If Intersect(Target(1, 1), Rng1) Is Nothing Then
        Exit Sub
    End If
    Cancel = True
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0

    Target(1, 1).Value = VBA.Format(Date1, "MM/DD/YYYY")
    
End Sub

**Armored Wing** · 01-13-2012, 01:20 PM

All right I have uploaded the sheet that I am currently working on. First, the second code worked so I want to thank you Kelshaer. My first problem now is that when any cell becomes "pending" in column F, I would like the date entry code to execute corresponding to the cell that become pending (so if cell F10 became pending, A10 would pop up the date prompt), otherwise the code won't execute at all. I hope that help clear up some confusion anyone might have.

**Kelshaer** · 01-13-2012, 01:38 PM

Here you go

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim r, c, u As Integer
    r = Target.Row
    c = Target.Column
    u = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    If c > 1 Or r > u Or VBA.UCase(Range("F" & r)) <> "PENDING" Then Exit Sub
    
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Target(1, 1).Value = VBA.Format(Date1, "mm/dd/yyyy")
End Sub

**Armored Wing** · 01-13-2012, 01:54 PM

I tried it out but the prompt does not pop up when pending display in F? Am I missing something?

**Kelshaer** · 01-13-2012, 02:01 PM

Its working for me
Please find the attached file

**Armored Wing** · 01-13-2012, 02:26 PM

Ok the macro does work on the active row and cell but is that a way to make it automatically appear the f column being turned into pending? Since I still have to double click it in order for the box to show up.

**Kelshaer** · 01-13-2012, 02:33 PM

If you mean to make it launch without considering which column was double clicked then use this:
Although i dont recommend it this way as you might double click any other column to enter data.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim r , u As Integer
    r = Target.Row
    u = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    If  r > u Or VBA.UCase(Range("F" & r)) <> "PENDING" Then Exit Sub
    
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Target(1, 1).Value = VBA.Format(Date1, "mm/dd/yyyy")
End Sub

**Armored Wing** · 01-13-2012, 02:44 PM

I guess what I want is that instead of double clicking, the moment that the cell F10 becomes pending, the cell in A10 will automatically prompt the user in entering a date which will display in cell A10. I don't know if that is feasible or not.

**Kelshaer** · 01-13-2012, 03:01 PM

Hope this will work

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim r, c, u As Integer
    r = Target.Row
    c = Target.Column
    u = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    If c > 1 Or r > u Or VBA.UCase(Range("F" & r)) <> "PENDING" Then Exit Sub
    
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Target(1, 1).Value = VBA.Format(Date1, "mm/dd/yyyy")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 4 And Target.Column <> 5 Then Exit Sub
    If VBA.UCase(Range("F" & Target.Row)) <> "PENDING" Or Range("A" & Target.Row) <> "" Then Exit Sub
        Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Range(Target.Row, 1).Value = VBA.Format(Date1, "mm/dd/yyyy")
    
    
End Sub

**Armored Wing** · 01-13-2012, 04:07 PM

It auto opens now but now an error message displays the run-time error 1004 with the range being the object that failed.

Range(Target.Row, 1).Value = VBA.Format(Date1, "mm/dd/yyyy")

**Kelshaer** · 01-13-2012, 06:02 PM

So Sorry, My mistake.
Here is it:




Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim r, c, u As Integer
    r = Target.Row
    c = Target.Column
    u = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    If c > 1 Or r > u Or VBA.UCase(Range("F" & r)) <> "PENDING" Then Exit Sub
    
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Target(1, 1).Value = VBA.Format(Date1, "mm/dd/yyyy")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 4 And Target.Column <> 5 Then Exit Sub
    If VBA.UCase(Range("F" & Target.Row)) <> "PENDING" Or Range("A" & Target.Row) <> "" Then Exit Sub
        Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Range("A" & Target.Row).Value = VBA.Format(Date1, "mm/dd/yyyy")
    
    
End Sub

**Armored Wing** · 01-14-2012, 02:33 PM

Please don't apologize for the errors, I just wish I was better at VBA so I can complete harder tasks. However, I am extremely grateful for your help, but I was wondering if you could help me out with one last thing. Using the code that you wrote, now I have to apply it to my finalized spreadsheet in which the columns which are pending will automatically prompt the user. I tried the code out but was unable to get the box opened. I will upload the finalized sheet for your reference.

Once again, I am extremely grateful for your help.

**Kelshaer** · 01-14-2012, 07:44 PM

Try this one

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim r, c, u As Integer
    r = Target.Row
    c = Target.Column
    u = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    If c <> 5 And c <> 11 Then Exit Sub
    If r > u Then Exit Sub
    If c = 5 Then
        If VBA.UCase(Range("D" & r)) <> "PENDING" Then Exit Sub
    ElseIf c = 11 Then
        If VBA.UCase(Range("J" & r)) <> "PENDING" Then Exit Sub
    End If
    
    Dim Rng1            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    Target.Value = VBA.Format(Date1, "mm/dd/yyyy")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 8 And Target.Column <> 9 Then Exit Sub
    
    If Target.Column = 2 Or Target.Column = 3 Then
        If VBA.UCase(Range("D" & Target.Row)) <> "PENDING" Or Range("E" & Target.Row) <> "" Then Exit Sub
    ElseIf Target.Column = 8 Or Target.Column = 9 Then
        If VBA.UCase(Range("J" & Target.Row)) <> "PENDING" Or Range("K" & Target.Row) <> "" Then Exit Sub
    End If
    
    Dim Prompt          As String
    Dim Title           As String
    Dim strDate1       As String
    Dim Date1 As Date
   
    
    Prompt = "Enter date formatted: mm/dd/yyyy"
    Title = "[Please Enter Date]"
    strDate1 = InputBox(Prompt, Title)
    
    
    On Error Resume Next
    Date1 = CDate(strDate1)
    If Err <> 0 Or strDate1 = "" Then
        Exit Sub
    End If
    On Error GoTo 0
    If Target.Column = 2 Or Target.Column = 3 Then
        Range("E" & Target.Row).Value = VBA.Format(Date1, "mm/dd/yyyy")
    ElseIf Target.Column = 8 Or Target.Column = 9 Then
        Range("K" & Target.Row).Value = VBA.Format(Date1, "mm/dd/yyyy")
    End If
End Sub

Macro for prompting date entry

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Re: Macro for prompting date entry

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions