Is there a better way to do this??

[BVHis]

I have a sheet that has some data validation set up so that you can'
enter the same thing twice withing a certain range. I did notice tha
you can get around this by typing in what you want, select the cell
then grab the lower-right corner of the highlighted selection and dra
which then creates multiple entries of the same thing. I want to avoi
that, but I can't seem to get something that looks "pleasing". Wha
I've managed to scrap together is shown in the code below. (I'm no
too fond of the UNDO part).

Here's the code that I have...

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TargetParts() As String
Dim i As Integer

On Error GoTo ErrMsg
If Target.Value = "" Then
TargetParts() = Split(Target.Address, "$")
If Left(Target.Address, 2) = "$A" Then
Range("B" & TargetParts(2)).Select
ActiveCell.FormulaR1C1 = ""
Range("C" & TargetParts(2)).Select
ActiveCell.FormulaR1C1 = ""
Range("A" & TargetParts(2) + 1).Select
End If
End If

If Target.Value <> "" Then
TargetParts() = Split(Target.Address, "$")
If Left(Target.Address, 2) = "$A" Then
Range("B" & TargetParts(2)).Select
ActiveCell.FormulaR1C1 = UCase$(Application.UserName)
Range("C" & TargetParts(2)).Select
ActiveCell.FormulaR1C1 = Format(Now, "MM/DD/YY hh:mm:s
AMPM")
Range("A" & TargetParts(2) + 1).Select
End If
End If
Exit Sub

ErrMsg:
If Err.Number = "13" Then
Application.Undo
Exit Sub
End If
End Sub

Thanks in advance!

~ Matt

 

[Dave Peterson]

How about something like this:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRng As Range
Dim myCell As Range

Set myRng = Intersect(Target, Me.Range("a:a"))

If myRng Is Nothing Then Exit Sub

On Error GoTo errhandler:

Application.EnableEvents = False
For Each myCell In myRng.Cells
With myCell
If .Text = "" Then
Me.Cells(.Row, "B").Resize(1, 2).ClearContents
Else
.Offset(0, 1).Value = Application.UserName
With .Offset(0, 2)
.Value = Now
.NumberFormat = "MM/DD/YY hh:mm:ss AM/PM"
End With
End If
If Target.Cells.Count = 1 Then
Target.Offset(1, 0).Select
End If
End With
Next myCell

errhandler:
Application.EnableEvents = True

End Sub

 

[BVHis]

Maybe it would help if I posted the file for you to better understan
what's going on.

Check out the Reservations tab.
Enter the number 1 in the SK # column.
Try to enter another 1 in the SK # column. See the message that pop
up? That's where I'm using the data validation. There should only b
one of any number in that column.
Now select the cell where you entered that number.
Grab the lower-right corner (the + symbol) and drag down. See how i
creates multiple 1's?? That's what I don't want the user to be able t
do, so in my code I'm using the UNDO function which makes Excel flas
like a strobe light.

Is there a way around that??


Thanks in advance!

~ Matt

Attachment filename: 0004000 - sample class project-revision log.zi
Download attachment: http://www.excelforum.com/attachment.php?postid=55980

 

[Dave Peterson]

I don't open attachments, but maybe...

application.screenupdating = false
'your undo code
application.screenupdating = true

Another option is to use a helper cell and put an error message in that cell.
It won't be exactly the same, but it might be enough to tell the user to fix the
data.

This has some trouble, but you may pick up an idea or two.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRng As Range
Dim myRngToCheck As Range
Dim myCell As Range
Dim ErrorCtr As Long

Set myRngToCheck = Me.Range("a:a")
Set myRng = Intersect(Target, myRngToCheck)

If myRng Is Nothing Then Exit Sub

On Error GoTo errhandler:
ErrorCtr = 0
Application.EnableEvents = False
For Each myCell In myRng.Cells
With myCell
If .Text = "" Then
Me.Cells(.Row, "B").Resize(1, 2).ClearContents
Else
If Application.CountIf(myRngToCheck, .Value) > 1 Then
'at least one already existed
.Resize(1, 3).ClearContents
ErrorCtr = ErrorCtr + 1
Else
.Offset(0, 1).Value = Application.UserName
With .Offset(0, 2)
.Value = Now
.NumberFormat = "MM/DD/YY hh:mm:ss AM/PM"
End With
End If
End If
End With
Next myCell

If ErrorCtr > 0 Then
MsgBox "An error occurred with your last changed." & vbLf _
& "Please check: " & myRng.Address(0, 0)
Else
If Target.Cells.Count = 1 Then
Target.Offset(1, 0).Select
End If
End If

errhandler:
Application.EnableEvents = True

End Sub