Help with existing pop up code

[Dazzawm]

I was given the codes within this thread http://www.mrexcel.com/forum/showthread.php?t=554868

Problem now is I have changed it from horizontal to vertical, so the names are going across the top and the dates down in column B. I need a pop up so that if someone has already an 'HP' in that date/row it will give a pop up saying 'such and such is already booked of that day' by looking at the name in row 3.

The names are ranging from C3:CB3 and the dates range from B4:B316

Thanks

 

[Dazzawm]

This is how it looks now. So if I put 'HP' in C5 under Tom a pop-up will tell me " Chris S is already booked off that day" or if I put 'HP' in I6 under John it will tell me ' James & Curtis are already booked off that day' and so on....

Excel Workbook
	A	B	C	D	E	F	G	H	I	J
1	RD	HP
2	MP	SU	Manager	Asst Manager	Warehouse	Warehouse	Driver	Driver	Driver	Driver
3	BH	HU	Tom	Chris M	Chris S	James	Curtis	Alan	John	Leslie
4	Monday	02/01/2012
5	Tuesday	03/01/2012			HP
6	Wednesday	04/01/2012				HP	HP
7	Thursday	05/01/2012
8	Friday	06/01/2012
9	Saturday	07/01/2012
10	Monday	09/01/2012
11	Tuesday	10/01/2012
12	Wednesday	11/01/2012
13	Thursday	12/01/2012
14	Friday	13/01/2012
15	Saturday	14/01/2012
Sheet1

[/B]

 

[Dazzawm]

^

 

[Dazzawm]

Come on guys help me please!!! lol

 

[MickG]

Try this for your Altered Layout:-
NB:-
I Assume each Rng that represents a "Depot" will be positioned Across the sheet rather than down.
As it is not apparent what each "Depot" is called I have used the Third Cell in the first row of each "Depot" range To hold the "Depot" name, so The first "Depot Name will be in "C1".

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim Rng As Range, Dn As Range
Dim num As Long
If Target.Count = 1 And Not Intersect(Target, Rows("3:3")) Is Nothing Then
    Cancel = True
     Set Rng = Range(Cells(4, Target.Column), Cells(Rows.Count, Target.Column).End(xlUp))
       num = Application.CountIf(Rng, "HP")
         MsgBox Target & " Has " & num & " HP's"
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range
Dim nDn As Range
Dim Msg As String
Dim nMsg As String
Dim nRng As Range
Dim Depot As String
Dim Fd As Boolean
Dim nFd As Boolean
Set Rng = Range(Range("C3"), Cells(3, Columns.Count).End(xlToLeft))
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
    For Each Dn In Rng.Areas
        If nRng Is Nothing Then
            Set nRng = Dn
        Else
            Set nRng = Union(nRng, Dn.Offset(, 2).Resize(, Dn.Count - 2))
        End If
Next Dn
For Each nDn In nRng.Areas
   If Not Intersect(Target, nDn.Offset(1).Resize(Rows.Count - 3)) Is Nothing Then Fd = True
Next nDn
If Fd Then
    For Each nDn In nRng.Areas
       Depot = nDn.Offset(-2).Resize(, 1)
        Set nDn = nDn.Offset(Target.Row - 3)
             For Each Dn In nDn
                If Target = "HP" And Dn <> "" And Not Dn.Address = Target.Address Then
                    Msg = Msg & Cells(3, Dn.Column) & Chr(10)
                 nFd = True
                End If
            Next Dn
                nMsg = nMsg & "Depot " & """" & Depot & """" & Chr(10) & Msg & Chr(10)
                Msg = ""
    Next nDn
End If
If nFd And Target = "HP" Then
    MsgBox "The following Staff are off today " & Chr(10) & Chr(10) & nMsg & Chr(10) & "Press ""OK"" to continue !!"
End If
End Sub

 

[Dazzawm]

I have too many 'Private Subs' and you have 2 on this code for them too work it seems. Below is the 2 codes I have already. 1 is to colour the cells as I enter the letters and the other tells me how many HPs there are when I right click on a name. Could you tell me or put your code amongst these please. thanks

Private Sub worksheet_beforerightclick(ByVal Target As Range, cancel As Boolean)
If Target.Row <> 3 Then Exit Sub
cancel = True
MsgBox Target.Value & " Has " & Application.CountIf(Target.EntireColumn, "HP") & " Days Booked So Far"
End Sub
 
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim intclr As Integer
 
If Target.Count > 1 Then Exit Sub
 
If Not Intersect(Target, Range("A1:CB316")) Is Nothing Then
 
Select Case Target
Case "HP": intclr = 40
Case "MP": intclr = 36
Case "SU": intclr = 35
Case "BH": intclr = 37
Case "HU": intclr = 43
Case "RD": intclr = 42
Case "": intclr = xlNone
Case Else
End Select
 
Target.Interior.ColorIndex = intclr
 
End If
 
End Sub

 

[MickG]

Choose which of the "Before Right Click" code you want then remove the code not required.
Add your second code to the First as shown below:-
NB:- I should "Remark" out all the existing codes first except the new Code "Change_Event". Make sure that is working correctly then add the Extra code.

'From Change Event code
If nFd And Target = "HP" Then
    MsgBox "The following Staff are off today " & Chr(10) & Chr(10) & nMsg & Chr(10) & "Press ""OK"" to continue !!"
End If
'Add your existing code here----
Dim intclr As Integer
 
If Target.Count > 1 Then Exit Sub
 
If Not Intersect(Target, Range("A1:CB316")) Is Nothing Then
 
Select Case Target
Case "HP": intclr = 40
Case "MP": intclr = 36
Case "SU": intclr = 35
Case "BH": intclr = 37
Case "HU": intclr = 43
Case "RD": intclr = 42
Case "": intclr = xlNone
Case Else
End Select
 
Target.Interior.ColorIndex = intclr
End If
End Sub

 

[Dazzawm]

Sorry I am well confused now!

 

[Dazzawm]

I have sorted that now I was being a ****. The depot ranges are C1 then the next starts at Q1 then AD1 then AP1 then BM1 and finally BW1. Can these ranges be added to your code?

 

[MickG]

From your thread it appears you have 2 "Before Right Click" events and 2 "Change_Events"
The "Before Right click appear to do the same thing" .i.e(Count the "HP"'s for individuals).
You only want one of these codes so, choose which one suits you better , and deleat the other,
My "Change Event" code Tells you whose on leave on a Particular date.
Your other "Change Event" code colours cells within a set range depending what their value is. You can join the 2 Change Events code to work as one, by Physically joining them as per my last reply.
Which shows the last few lines of my code and the start of where to paste your code.
Mick