Populate a cell with a date using DatePicker

[John1953]

When I select a cell to add a date using DatePicker drop down box, I select a date but nothing displays in the selected cell. The code I used is;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


With Sheet1.DTPicker1
.Height = 20
.Width = 20
If Not Intersect(Target, Range("A:A")) Is Nothing Then
.Visible = True
.Top = Target.Top
.Left = Target.Offset(0, 1).Left
Linkedcell = Target.Address
Else
.Visible = False
End If
End With
End Sub

 

[DanteAmor]

Hi John, welcome to the forum.

Try this

- Select cell on column A
- Select Date
- Or press Esc or any cell to hide dtpicker
- Or change date in the box and press Enter

Private Sub DTPicker1_Change()
  With Sheet1.DTPicker1
    ActiveCell.Value = .Value
    .Visible = False
    ActiveCell.Activate
  End With
End Sub


Private Sub DTPicker1_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
    With Sheet1.DTPicker1
      ActiveCell.Value = .Value
      .Visible = False
      ActiveCell.Activate
    End With
  End If
End Sub


Private Sub DTPicker1_LostFocus()
  Sheet1.DTPicker1.Visible = False
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Range("A:A")) Is Nothing Then
    With Sheet1.DTPicker1
      .Visible = True
      .Top = Target.Top
      .Left = Target.Offset(0, 1).Left
    End With
  Else
    Sheet1.DTPicker1.Visible = False
  End If
End Sub

 

[DanteAmor]

I can't answer your private message because your mailbox is full

 

[John1953]

DanteAmor

I entered your code as shown and it works great, however, if I select a row (row number on the left) I get the following message;
Run-Time error '1004';
Application-Defined or Object-Defined error

Any ideas?

 

[DanteAmor]

DanteAmor

I entered your code as shown and it works great, however, if I select a row (row number on the left) I get the following message;
Run-Time error '1004';
Application-Defined or Object-Defined error

Any ideas?

Try this, add line in red.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[COLOR=#ff0000]if target.count > 1 then exit sub[/COLOR]
  If Not Intersect(Target, Range("A:A")) Is Nothing Then
    With Sheet1.DTPicker1
      .Visible = True
      .Top = Target.Top
      .Left = Target.Offset(0, 1).Left
    End With
  Else
    Sheet1.DTPicker1.Visible = False
  End If
End Sub