View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Ron Rosenfeld Ron Rosenfeld is offline
external usenet poster
 
Posts: 5,651
Default VBA to superscript a part of a cell

On Thu, 15 Apr 2010 10:24:05 -0700 (PDT), Mikhail Bogorad
wrote:

hi
i have a report that populates some text descriptions in cells range
B2:B15. So sometimes text has a date, for example "... October
1st...". What i want is to superscript letters "st" every time it
finds "1st".

Has anyone ever encountered this problem before?

Thanks


There are some issues you haven't mentioned.

1. Are the cell contents strings, or are they the results of formulas. If
they are the results of formulas, then they must be converted to strings in
order to superscript a few letters.

2. Could there be more than one substring that requires superscripting. For
example, May 21st through May 28th ?

3. How do you want to handle a number followed by two letters that do not
represent a valid ordinal suffix? For example: 101th day of the year.

Here is a routine that
If the contents of the cell "qualify" by containing an ordinal number,
then the contents will be converted to a text string in order to apply the
ordinal superscripting.
If the ordinal value is not valid, nothing will be done.
It can handle any number of ordinal values within the string.

================================================== =========
Option Explicit
Sub SupScriptOrdinal()
Dim re As Object, mc As Object, m As Object
Dim Suffix As String
Dim N As Long
Dim SuffixStart As Long
Dim c As Range

For Each c In Range("B2:B15")

Set re = CreateObject("vbscript.regexp")
re.Pattern = "\b(\d+)(\w{2})\b"
re.Global = True

If re.test(c) = True Then
Set mc = re.Execute(c)
For Each m In mc
N = m.SubMatches(0)
Select Case N Mod 10
Case Is = 1
Suffix = "st"
Case Is = 2
Suffix = "nd"
Case Is = 3
Suffix = "rd"
Case Else
Suffix = "th"
End Select

Select Case N Mod 100
Case 11 To 19
Suffix = "th"
End Select

If Suffix = LCase(m.SubMatches(1)) Then
'comment next line if you do not want to convert
' qualifying contents to text strings
c.Value = c.Text
SuffixStart = m.FirstIndex + 1 + Len(CStr(N))
c.Characters(SuffixStart, 2).Font.Superscript = True
End If

Next m
End If
Next c
End Sub
===================================
--ron