Nothing from the OP... I guess he is going to miss out on my solution. Too bad.

--
Rick (MVP - Excel)


"Gord Dibben" <gorddibbATshawDOTca wrote in message ...
Excellent revision.

I am sure this exercise will help OP and anyone else needing similar
operation.

A keeper.


Gord

On Sat, 7 Feb 2009 13:16:09 -0500, "Rick Rothstein"
wrote:

Thanks! And good catch! That is what I get for testing with letters only.<g

I decided to make a couple of changes to the macro, one of which handles the
problem you mentioned. Originally, I just changed the output to add an
apostrophe in front of the cell's content... that stopped the date problem.
But then I decided the output for numbers might be confusing. For example,
if you see this, 4-3, it might take a moment to realize that there are 4
threes and not 3 fours. Anyway, I decided to put quote marks around the
character in order to emphasize it... that solved the date problem and made
reading the results easier (IMHO). Next, I decided by going across the row,
the column widths made it hard to read all the differences if there were a
lot of them, so I changed the print out orientation to "down the column"
instead of "across the row". This has the side benefit of allowing more than
254 differences (in case the messages are quite long). Here is the revised
code...

Sub LetterNeededForSignChange()
Dim X As Long
Dim OldMessage As String
Dim NewMessage As String
Dim Add() As String
Dim Remove() As String
Dim OldLetters(32 To 126) As Long
Dim NewLetters(32 To 126) As Long

Const SheetName As String = "Sheet2"
Const OldMessageCell As String = "A1"
Const NewMessageCell As String = "A2"
Const OutputCell As String = "A4"

ReDim Add(0)
ReDim Remove(0)
Add(0) = "Add"
Remove(0) = "Remove"
With Worksheets(SheetName)
OldMessage = .Range(OldMessageCell).Value
NewMessage = .Range(NewMessageCell).Value
For X = 1 To Len(OldMessage)
OldLetters(Asc(Mid(OldMessage, X, 1))) = _
OldLetters(Asc(Mid(OldMessage, X, 1))) + 1
Next
For X = 1 To Len(NewMessage)
NewLetters(Asc(Mid(NewMessage, X, 1))) = _
NewLetters(Asc(Mid(NewMessage, X, 1))) + 1
Next
For X = 33 To 126
If NewLetters(X) < OldLetters(X) Then
ReDim Preserve Remove(UBound(Remove) + 1)
Remove(UBound(Remove)) = Abs(NewLetters(X) - OldLetters(X)) & _
" - """ & Chr(X) & """"
ElseIf NewLetters(X) OldLetters(X) Then
ReDim Preserve Add(UBound(Add) + 1)
Add(UBound(Add)) = (NewLetters(X) - OldLetters(X)) & _
" - """ & Chr(X) & """"
End If
Next
.Range(OutputCell).Resize(5000, 2).Clear
For X = 0 To UBound(Remove)
.Range(OutputCell).Offset(X).Value = Remove(X)
Next
For X = 0 To UBound(Add)
.Range(OutputCell).Offset(X, 1).Value = Add(X)
Next
Range(OutputCell).Resize(1, 2).Font.Underline = True
End With
End Sub