ChristineJ
Well-known Member
- Joined
- May 18, 2009
- Messages
- 775
- Office Version
- 365
- Platform
- Windows
This code below from my worksheet creates a pop-up box when certain cells in columns Q, S, and U have a value and are selected. The contents of the pop-up include the text values in other cells in the same row. (Blue text below.)
I'd like to ADD similar functionality for creating the pop-ups in certain cells in columns BI, BK, BM, and BO. However, rather than pulling the text values in the pop-ups from cells in the same row, I would like any cell in a column to have the same contents in the pop-up.
For example, when any cell in the range in BI is clicked on, its pop-up would have:
This is test 1.
This is test 2.
This is test 3.
ANSWER: 55
When any cell in the range in BK is selected, the pop-up would have:
This is test 4.
This is test 5.
This is test 6.
ANSWER: 77
Same for the other two columns. The text sentences would vary quite a bit more than my example above.
Can this code be modified? Thanks.
I'd like to ADD similar functionality for creating the pop-ups in certain cells in columns BI, BK, BM, and BO. However, rather than pulling the text values in the pop-ups from cells in the same row, I would like any cell in a column to have the same contents in the pop-up.
For example, when any cell in the range in BI is clicked on, its pop-up would have:
This is test 1.
This is test 2.
This is test 3.
ANSWER: 55
When any cell in the range in BK is selected, the pop-up would have:
This is test 4.
This is test 5.
This is test 6.
ANSWER: 77
Same for the other two columns. The text sentences would vary quite a bit more than my example above.
Can this code be modified? Thanks.
Rich (BB code):
Dim strTitle As String
Dim strMsg As String
Dim lDVType As Long
Dim sTemp As Shape
On Error Resume Next
Set sTemp = ActiveSheet.Shapes("txtInputMsg")
'*
'Code will only work if A13=1 (pop-ups) A34=1 so pop-up does not appear before grading occurs (next line)
If Range("B6").Value <> 1 Then Exit Sub
If Range("A34").Value <> 1 Then Exit Sub
'* Add the box if does not exist
If Err.Number <> 0 Then
Set sTemp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 72, 72)
sTemp.Name = "txtInputMsg"
End If
'*
'* Exit if not in range
With Target
' test whether there is more than one cell in the selection, that the cell is in
' column 'Q', 'S', or 'U' (Each of these is a named range), that there is something in the cell
' and that it has a validation rule applied.
lDVType = 99
lDVType = Target.Validation.Type
If 1 < .Cells.Count Or _
Application.Intersect(.Cells, Union(Range("ColumnQ"), Range("ColumnS"), Range("ColumnU"))) Is Nothing Or _
.Value = "" Or lDVType = 99 Then
sTemp.TextFrame.Characters.Text = ""
sTemp.Visible = msoFalse
Else
Application.EnableEvents = False
.Validation.ShowInput = False
Select Case .Column
'Each of these is the column number
Case 17 '* Column Q
strTitle = IIf(CStr(Range("AO" & .Row)) = "", "", (CStr(Range("AO" & .Row)) & vbCr)) & _
IIf(CStr(Range("AP" & .Row)) = "", "", (CStr(Range("AP" & .Row)) & vbCr)) & _
IIf(CStr(Range("AQ" & .Row)) = "", "", (CStr(Range("AQ" & .Row)) & vbCr))
strMsg = IIf(CStr(Range("AG" & .Row)) = "", "ANSWER: Leave blank", "ANSWER: " & _
CStr(Range("AG" & .Row)))
Case 19 '* Column S
strTitle = IIf(CStr(Range("AR" & .Row)) = "", "", (CStr(Range("AR" & .Row)) & vbCr)) & _
IIf(CStr(Range("AS" & .Row)) = "", "", (CStr(Range("AS" & .Row)) & vbCr)) & _
IIf(CStr(Range("AT" & .Row)) = "", "", (CStr(Range("AT" & .Row)) & vbCr))
strMsg = IIf(CStr(Range("AI" & .Row)) = "", "ANSWER: Leave blank", "ANSWER: " & _
CStr(Format(Range("AI" & .Row), "#,###")))
Case 21 '* Column U
strTitle = IIf(CStr(Range("AU" & .Row)) = "", "", (CStr(Range("AU" & .Row)) & vbCr)) & _
IIf(CStr(Range("AV" & .Row)) = "", "", (CStr(Range("AV" & .Row)) & vbCr)) & _
IIf(CStr(Range("AW" & .Row)) = "", "", (CStr(Range("AW" & .Row)) & vbCr))
strMsg = IIf(CStr(Range("AK" & .Row)) = "", "ANSWER: Leave blank", "ANSWER: " & _
CStr(Format(Range("AK" & .Row), "#,###")))
End Select
strMsg = IIf(Range("B1") = 3, "", strMsg)
strTitle = IIf(Range("B1") = 2, "", strTitle)
'*
'* Remove last vbCR from strTitle if strMsg = ""
strTitle = IIf(strMsg = "", LEFT(strTitle, Len(strTitle) - 1), strTitle)
sTemp.TextFrame.Characters.Text = strTitle & strMsg
sTemp.TextFrame.AutoSize = True
sTemp.TextFrame.Characters.Font.Bold = False
sTemp.TextFrame.Characters(1, Len(strTitle)).Font.Bold = False
sTemp.LEFT = .Offset(0, -5).LEFT
sTemp.Top = .Top - sTemp.Height
sTemp.Visible = msoTrue
On Error GoTo 0
Application.EnableEvents = True
End If
End With
