How to allow "if then" text?

[Kenshe]

Looking for a way to allow only three possible entries into a field and
using a one letter entry to spell out the full word of that entry,
Example:

If "P" then (the word) "Pass" is entered.
If "F" then "Fail"
If "N" then N/A

I believe this can only be achieved using a macro, which I have no clue
how to write.

Thanks!

Ken

 

[Bernard Liengme]

Two formulas without macros
1) =IF(D19="P","Pass",IF(D19="F","Fail",IF(D19="N","N/A","Invalid")))

2) =LOOKUP(D19,{"F","N","P"},{"Fail","N/A","Pass"})

 

[Alan]

Try
=IF(A1="P","Pass",IF(A1="F","Fail",IF(A1="N/A","N/A","Put an error message
here")))
Regards,
Alan.

 

[Otto Moehrbach]

I believe the OP wants to enter the one letter into a cell and have the
resulting word automatically entered into that same cell.
Kenshe
The following macro will do what you want. This is a Worksheet_Change
event macro and is triggered automatically upon any change to the contents
of any cell in the sheet. I'm assuming that you want this to work within a
specific range only and not all over the sheet. The range A1:A10 is used in
this macro. Change it to suit your needs. Note that this macro works with
either case of P, F, and N.
This macro must be placed in the sheet module of the pertinent sheet.
To do that, right-click on the sheet tab, select View Code, and paste this
macro into that module. Click on the "X" in the top right corner to get
back to your sheet. HTH Otto
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = "" Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If UCase(Target) = "P" Then
Target = "Pass"
Else
If UCase(Target) = "F" Then
Target = "Fail"
Else
If UCase(Target) = "N" Then Target = "N/A"
End If
End If
End If
End Sub

 

[Skin]

I use a similar example and this works for me
Try Auto Correct P = Pass, F= Fail, N = N/A. Then use data validation For
these letters.
Paul.

 

[Kenshe]

That is correct OM, I desire to do just that, I will give it a go
today.

Thanks to all for the quick response! I will post back with the
results.

Ken

 

[Kenshe]

Hey thanks Otto, it works great, should help speed up the process
greatly!

One other possibility though, is there another line of code that could
possibly be added to restrict the cell from allowing anything but P, F
or N/A?

Again, Thanks!

Ken

 

[Otto Moehrbach]

Ken
Here it is. I changed the code to a Select Case construct. That is
easier to follow than the nested "IF" statements. HTH Otto
Private Sub Worksheet_Change(ByVal Target As Range)
If Target = "" Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Application.EnableEvents = False
Select Case UCase(Target.Value)
Case "P": Target.Value = "Pass"
Case "F": Target.Value = "Fail"
Case "N": Target.Value = "N/A"
Case Else
MsgBox "Only 'P', 'F', or 'N' are allowed in this cell."
Target.ClearContents
End Select
Application.EnableEvents = True
End If
End Sub

 

[Kenshe]

Otto,
Works great, your help and knowledge is much appreciated to a novic
like me.

If possible, I have one more request,

I am looking for a way to gather up all the "comments" into a singl
report sheet. I have 29 sheets in the work book, the 30th sheet i
where I would like to copy any comments we may have. The cell rang
where a comment can only be put (from the 29sheets) is B25:IV29.
Right now I use Word imbedded into sheet 30 and copy and paste. so,
am looking for an easier way to compile all the comments to read in
single report. Word works good for this task, but the time it takes t
copy and paste is the issue.

Thanks much!

Ke

 

[Dave Peterson]

One way:

Option Explicit
Sub testme()

Dim cmt As Comment
Dim wks As Worksheet
Dim rptWks As Worksheet
Dim DestCell As Range

Set rptWks = Worksheets.Add
With rptWks
.Range("a1").Resize(1, 3).Value _
= Array("Sheet Name", "Address", "Text")
Set DestCell = rptWks.Range("a2")
End With

For Each wks In ActiveWorkbook.Worksheets
If wks.Name = rptWks.Name Then
'do nothing
Else
For Each cmt In wks.Comments
DestCell.Value = "'" & wks.Name
DestCell.Offset(0, 1).Value = cmt.Parent.Address(0, 0)
DestCell.Offset(0, 2).Value = cmt.Text
Set DestCell = DestCell.Offset(1, 0)
Next cmt
End If
Next wks

End Sub

ps. Debra Dalgleish has some code that you may want to review:
http://www.contextures.com/xlcomments03.html#CopyToWord

It wouldn't be difficult to loop through the worksheets.

 

[Max]

Dave,
Found your sub v.useful in documenting comments from all sheets.
Could it be tweaked a little to similarly write the text from all textboxes
and other autoshapes in all sheets ? Thanks.

 

[Dave Peterson]

There are lots of shapes that could be out there!

If I had a choice, I'd loop through the ones I want.

Option Explicit
Sub testme()
Dim myShp As Shape
On Error Resume Next
For Each myShp In ActiveSheet.Shapes
MsgBox myShp.DrawingObject.Caption
Next myShp
On Error GoTo 0

Dim TB As TextBox 'from drawing toolbar
For Each TB In ActiveSheet.TextBoxes
MsgBox TB.Caption
Next TB

Dim OLEObj As OLEObject 'from control toolbox
For Each OLEObj In ActiveSheet.OLEObjects
If TypeOf OLEObj.Object Is MSForms.TextBox Then
MsgBox OLEObj.Object.Text
End If
Next OLEObj

End Sub

I put an oval from the drawing toolbar on a worksheet. I selected it and put
=a1 in the formula bar.

It confused excel into thinking it was a textbox from the drawing toolbar. It
blew up that middle routine pretty good.

Ron de Bruin has some techniques to examine the shape:
http://www.rondebruin.nl/controlsobjectsworksheet.htm

Shapes are pretty ugly if you don't know what's there (my opinion).

 

[Max]

Dave, thanks. I like what you've written.
But I need the sub to write from the msgboxes
into consecutive cells in a new sheet.

I put an oval from the drawing toolbar on a worksheet.
I selected it and put =a1 in the formula bar.

I won't have such linked textboxes or shapes,
so there shouldn't be any sub-explosion risks

Thanks

 

[Dave Peterson]

Just a general approach...

dim oWks as worksheet
dim orow as long

set owks = worksheets.add
orow = 1
for each something in acollectionof.somethings
'determine if you found something you want to keep
if itskeepable then
orow = orow + 1
owks.cells(orow,"A").value = firstthingtokeep
owks.cells(Orow,"B").value = secondthingtokeep
owks.cells(orow,"C").value = thirdthingtokeep
end if
next something

Is that enough? If you have trouble with that, er, whatever it was, post back
with the existing code you're using.

 

[Max]

Is that enough?

Not quite, sorry. Here's my attempt (it's not working of course)

Option Explicit
Sub testme()
Dim myShp As Shape
Dim oWks As Worksheet
Dim orow As Long
On Error Resume Next

Set oWks = Worksheets.Add
orow = 1
For Each myShp In ActiveSheet.Shapes
' MsgBox myShp.DrawingObject.Caption
If myShp Then
orow = orow + 1
oWks.Cells(orow, "A").Value = myShp.DrawingObject.Caption
'oWks.Cells(orow, "B").Value = secondthingtokeep
'oWks.Cells(orow, "C").Value = thirdthingtokeep
End If
Next myShp
On Error GoTo 0

Dim TB As TextBox 'from drawing toolbar
For Each TB In ActiveSheet.TextBoxes
MsgBox TB.Caption
' gotta do the same somewhere here, I think .. sheesh
Next TB

Dim OLEObj As OLEObject 'from control toolbox
For Each OLEObj In ActiveSheet.OLEObjects
If TypeOf OLEObj.Object Is MSForms.TextBox Then
MsgBox OLEObj.Object.Text
' gotta do the same again somewhere here, I think .. sheesh
End If
Next OLEObj

'and gotta loop all the other worksheets, I think .. urgh

End Sub

 

[Dave Peterson]

First, remember that every object you put on a sheet will be a shape--but not
all shapes are textboxes (from the drawing toolbar or from the control toolbox
toolbar).

So "for each myshp in wks.shapes" will pick up the textboxes, too. You can use
Ron's notes to eliminate the shapes (myshp.type stuff).

But this may get you closer (maybe just eliminating the textbox stuff (both of
them) would be sufficient.


Option Explicit
Sub testme()
Dim myShp As Shape
Dim wks As Worksheet
Dim oWks As Worksheet
Dim oRow As Long
Dim TB As TextBox 'from drawing toolbar
Dim OLEObj As OLEObject 'from control toolbox

Set oWks = Worksheets.Add

oRow = 1
For Each wks In ActiveWorkbook.Worksheets
On Error Resume Next
For Each myShp In wks.Shapes
'look at Ron de Bruin's site to eliminate the shapes
'you want to avoid
'If myShp.type = Then
oRow = oRow + 1
oWks.Cells(oRow, "A").Value = "'" & wks.Name
oWks.Cells(oRow, "b").Value = myShp.Name
oWks.Cells(oRow, "c").Value = myShp.DrawingObject.Caption
'End If
Next myShp
On Error GoTo 0

For Each TB In wks.TextBoxes
oRow = oRow + 1
oWks.Cells(oRow, "A").Value = "'" & wks.Name
oWks.Cells(oRow, "b").Value = TB.Name
oWks.Cells(oRow, "c").Value = TB.Caption
Next TB

For Each OLEObj In wks.OLEObjects
If TypeOf OLEObj.Object Is MSForms.TextBox Then
oRow = oRow + 1
oWks.Cells(oRow, "A").Value = "'" & wks.Name
oWks.Cells(oRow, "b").Value = OLEObj.Name
oWks.Cells(oRow, "c").Value = OLEObj.Object.Text
End If
Next OLEObj
Next wks

End Sub

I added some junk in column A and column B so you could tell where column C came
from.

 

[Max]

.. But this may get you closer ..

Yes, it certainly did. It works great.
Many thanks, Dave !

 

[Dave Peterson]

Glad to help.

Yes, it certainly did. It works great.
Many thanks, Dave !

--

 

[Kenshe]

Dave,

Thanks for the macro, it really works great! The other macro from your
suggested site is a little more problematic for what I am trying to
achieve. I have been working with the one you posted and I am having a
little trouble in modifying it.
It works great and is ready to use, but I notice I needed to generate
the "comment" report by date. I wanted to generate a new report every
day leaving out the previous comments already generated the day before.
Another words, the current comments for that day are the only coments
being reported. For once I create a report and print it, I delete the
created report page (sheet 1) for that day. I dont want to keep
reporting the old comments along with the new.

Here is the modified macro I am using:

Private Sub CommandButton1_Click()
Dim cmt As Comment
Dim wks As Worksheet
Dim rptWks As Worksheet
Dim DestCell As Range
ActiveWorkbook.Unprotect
Set rptWks = Worksheets.Add
With rptWks
..Range("a1").Resize(1, 3).Value _
= Array("Sheet", "Location", "Comment")
Set DestCell = rptWks.Range("a2")
End With

With ActiveSheet.Range("C1")
..ColumnWidth = 600 / .Width * .ColumnWidth
End With

For Each wks In ActiveWorkbook.Worksheets
If wks.Name = rptWks.Name Then
'do nothing
Else
For Each cmt In wks.Comments
DestCell.Value = "'" & wks.Name
DestCell.Offset(0, 1).Value = cmt.Parent.Address(0, 0)
DestCell.Offset(0, 2).Value = cmt.Text
Set DestCell = DestCell.Offset(1, 0)
Next cmt
End If
Next wks
Sheets("Comment Rpt").Select
ActiveWorkbook.Protect Structure:=True, Windows:=False
End Sub

Private Sub CommandButton2_Click()

'
' SheetDelete Macro
' Macro recorded 12/9/2005 by Oliver User
'

'
Sheets("Sheet1").Select
ActiveWorkbook.Unprotect
ActiveWindow.SelectedSheets.Delete
ActiveWorkbook.Protect Structure:=True, Windows:=False
End Sub


Maybe it would be better not use the "comment" window and just enter
any needed comments in a cell and use a bunch of "if then" statements
to do what I need with more avenues of attack??

Thanks again for all your help!

Ken

 

[Dave Peterson]

I don't see anything where you're keeping track of when the comments were
added. And that's gonna make the solution much more difficult than it has to
be. (I think you'd have to keep the historical comments, compare addresses of
the comment's cell and then compare the comment itself--sounds like a problem
just waiting to happen!)

Personally, if I have a choice between using comments and using cells, I'll use
cells. There's lots of things you could do based on cells (autofilter/sorting)
that become a problem with comments.

I think I'd use cells to contain the info. In fact, I'd add another column that
included the date that the "comment" was added. Then you could retrieve any set
of comments you wanted.

And you could have an even macro fire each time you changed a cell in a certain
column that would put the date in another column.

J.E. McGimpsey shows how at:
http://www.mcgimpsey.com/excel/timestamp.html