Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Code not working for multiple selection 2

Status
Not open for further replies.
deedar

deedar

Programmer
Aug 23, 2007
45
PK
I have made a performance evaluation system in an Excel Sheet. I am facing one problem in it. In this system, ratings are entered on a letter scale of A, B or C for three headings/columns. Each employee gives rating to each other employee. User can enter A or B for any employee. Blank entries are treated as C. Rating A cannot exceed 30% and rating B cannot exceed 40%. Rating percentages are calculated in cells E27, E28 and E29 for heading 1 as follows:

E27 (For Rating A):
ROUND((COUNTIF($E$4:$E$23,"A")/(COUNTA($D$4:$D$23)))*100,0)

E28 (For Rating B):
ROUND((COUNTIF($E$4:$E$23,"B")/(COUNTA($D$4:$D$23)))*100,0)

E29 (For Rating C):
IF(OR(E27>0,E28>0),100-E28-E27,0)

To control A or B ratings entry above limit, the following code is written:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ErrorHandler
If Target.Column <> 5 And Target.Column <> 6 And Target.Column <> 7 Then
    Exit Sub
Else
    Select Case Target.Column
        Case 5
            If Target.Value = "A" And Range("$E$27") > 30 Then
                MsgBox "Rating A cannot exceed 30%"
                Target.ClearContents
            ElseIf Target.Value = "B" And Range("$E$28") > 40 Then
                MsgBox "Rating B cannot exceed 40%"
                Target.ClearContents
            Else
            End If
        Case 6
            If Target.Value = "A" And Range("$F$27") > 30 Then
                MsgBox "Rating A cannot exceed 30%"
                Target.ClearContents
            ElseIf Target.Value = "B" And Range("$F$28") > 40 Then
                MsgBox "Rating B cannot exceed 40%"
                Target.ClearContents
            Else
            End If
        Case 7
            If Target.Value = "A" And Range("$G$27") > 30 Then
                MsgBox "Rating A cannot exceed 30%"
                Target.ClearContents
            ElseIf Target.Value = "B" And Range("$G$28") > 40 Then
                MsgBox "Rating B cannot exceed 40%"
                Target.ClearContents
            Else
            End If
    End Select
End If

ErrorHandler:
Exit Sub

End Sub

The problem is that this code works well when the user enters A or B rating in individual cells, but if he selects multiple cells then this code does not work. For example, I entered rating A in cell E4, copied it and pasted it from cell E5 to E23. Now cell E27 is showing 100 whereas in my scenario, cell E27 should never exceed 30.




 
Sort by date Sort by votes






Please explain your logic. What you have posted is not consistent. You state that columns E, F & G are for ratings A, B & C respectively, but then you count occurrences of A & B in column E.

So FIRST, please explain the LOGIC of this rating system.

Then SECOND, explain how you are attempting to implement this on this sheet.

Please explain BOTH in great detail, with clarity and completeness.

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
Target in this case is a set of cells. Depending on your needs, temporarily swith off events (Application.EnableEvents=False) and proceed with each cell (For Each c in Target.Cells), or tell user thet he can't work with multiple selection (If Target.Cells.Count>1 Then).

combo
 
Upvote 0 Downvote
Thanks Skip and combo.

I did not state that columns E, F & G are for ratings A, B & C respectively. I said ratings are entered on a letter scale of A, B or C for three headings/columns. These three headings/columns are Behavior, Occupation-Specific and Work Ethics respectively. For each of the columns E, F & G, ratings A or B are entered and blank entries are treated as C. For occupation-specific column, user can enter ratings only for staff belonging to his staff category.

For example, for an employee XYZ:
User will enter A or B under column E (Behavior) or will leave it blank.
Similarly, user will enter A or B under column F (Occupation-Specific) for employee XYZ or will leave it blank.
And user will enter A or B under column G (Work Ethics) for employee XYZ or will leave it blank.

User will enter ratings in similar way for all staff of his office. Each user will get a separate sheet of the workbook to enter ratings. This has been controlled by asking a password at the time of opening workbook and based on password, sheet relevant to that user is shown.

I said that cells E27, E28 and E29 (are) for heading 1 (Behavior).
Similarly cells F27, F28 and F29 are for heading 2 (Occupation-Specific) and cells G27, G28 and G29 are for heading 3 (Work Ethics). Formulas in these cells are as follows:

F27:
ROUND((COUNTIF($F$4:$F$23,"A")/(COUNTIF($D$4:$D$23,"Administration")))*100,0)
F28:
ROUND((COUNTIF($F$4:$F$23,"B")/(COUNTIF($D$4:$D$23,"Administration")))*100,0)
F29:
IF(OR(F27>0,F28>0),100-F28-F27,0)
(Administration is just one example of Staff Category)

G27:
ROUND((COUNTIF($G$4:$G$23,"A")/(COUNTA($D$4:$D$23)-1))*100,0)
G28:
ROUND((COUNTIF($G$4:$G$23,"B")/(COUNTA($D$4:$D$23)-1))*100,0)
G29:
IF(OR(G27>0,G28>0),100-G28-G27,0)

I would prefer to tell user that he can't work with multiple selection. I tried the following code:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then
    MsgBox "Multiple Selection not allowed"
    Target.ClearContents
    Exit Sub
End If
End Sub

But the program is being called repetitively at the line:

Code: 
Target.ClearContents

I traced the code and Target.ClearContents causes Worksheet_Change to be called again and the program stuck in this code.




 
Upvote 0 Downvote
Why clearing the selected cells ?
Anyway, have a look at the EnableEvents property.

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
Thanks PHV.

The following code worked:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then
    MsgBox "Multiple Selection not allowed"
    Application.EnableEvents = False
    Target.ClearContents
    Application.EnableEvents = True
End If
End Sub

Clearing the selected cells is necessary because I need rating A not to exceed 30% and rating B not to exceed 40%. So, suppose in column E, range E4:E23, behavior ratings (A or B) are to be entered for 20 employees. Suppose I enter A in cell E4, copy E4 and paste in from E5 to E10. Now rating A has become 35% ((7/20)*100), which is not allowed. So, in case of multiple selection, since the Worksheet_Change event is fired after the Paste operation, so I need to clear the selected cells.
 
Upvote 0 Downvote
Thanks for all your help and support. Below is the final code listing in my scenario:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ErrorHandler

If Target.Cells.Count > 1 Then
    If Evaluate("=COUNTA(" & Target.Address & ")") = 0 Then
        'This is a delete operation
        Exit Sub
    Else
        'This is a Paste or Entry operation
        MsgBox "Entering values in muliple cells not allowed"
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
        Exit Sub
    End If
End If

If Target.Column <> 5 And Target.Column <> 6 And Target.Column <> 7 Then
    Exit Sub
Else
    Select Case Target.Column
        Case 5
            If Target.Value = "A" And Range("$E$27") > 30 Then
                MsgBox "Rating A cannot exceed 30%"
                Application.EnableEvents = False
                Target.ClearContents
                Target.Activate
                Application.EnableEvents = True
            ElseIf Target.Value = "B" And Range("$E$28") > 40 Then
                MsgBox "Rating B cannot exceed 40%"
                Application.EnableEvents = False
                Target.ClearContents
                Target.Activate
                Application.EnableEvents = True
            Else
            End If
        Case 6
            If Target.Value = "A" And Range("$F$27") > 30 Then
                MsgBox "Rating A cannot exceed 30%"
                Application.EnableEvents = False
                Target.ClearContents
                Target.Activate
                Application.EnableEvents = True
            ElseIf Target.Value = "B" And Range("$F$28") > 40 Then
                MsgBox "Rating B cannot exceed 40%"
                Application.EnableEvents = False
                Target.ClearContents
                Target.Activate
                Application.EnableEvents = True
            Else
            End If
        Case 7
            If Target.Value = "A" And Range("$G$27") > 30 Then
                MsgBox "Rating A cannot exceed 30%"
                Application.EnableEvents = False
                Target.ClearContents
                Target.Activate
                Application.EnableEvents = True
            ElseIf Target.Value = "B" And Range("$G$28") > 40 Then
                MsgBox "Rating B cannot exceed 40%"
                Application.EnableEvents = False
                Target.ClearContents
                Target.Activate
                Application.EnableEvents = True
            Else
            End If
    End Select
End If

ErrorHandler:
Exit Sub

End Sub



 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

remeng
  • Locked
  • Solved
Combine two working macros into one for MS Word 1
Replies
7
Views
561
strongm
strongm
remeng
  • Locked
  • Question
multiple err handling
Replies
6
Views
329
remeng
remeng
morechocolate
  • Locked
  • Question
run-tune error 3704 operation is not allowed when the object is codes: I don't think so.
Replies
7
Views
635
morechocolate
morechocolate
Kymenglish
  • Locked
  • Question
Automated data entry code in MS Excel VB - Edge code how to hit enter to remove popups
Replies
3
Views
222
strongm
strongm
remeng
  • Locked
  • Question
Multiple Users in a Macro enabled Excel Doc
Replies
0
Views
159
remeng
remeng

Part and Inventory Search

Sponsor

Back
Top