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

VBA to superscript a part of a cell
 

On Thu, 15 Apr 2010 21:07:16 -0400, Ron Rosenfeld
wrote:

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

Oops. A change.

If you want to convert qualifying contents produced by a formula into a text
string, you need to do it this way:

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

Otherwise, only the last ordinal gets superscripted as things get overwritten
each time through.

So the entire routine:

==============================
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 Selection

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
If c.HasFormula = True Then 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

VBA to superscript a part of a cell
 

"Ron Rosenfeld" wrote in message
...
On Thu, 15 Apr 2010 21:07:16 -0400, Ron Rosenfeld

wrote:

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

Oops. A change.

If you want to convert qualifying contents produced by a formula into a
text
string, you need to do it this way:

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

Otherwise, only the last ordinal gets superscripted as things get
overwritten
each time through.

So the entire routine:

==============================
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 Selection

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
If c.HasFormula = True Then 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

Couple of thoughts

Why not place these lines before the loop, particularly the first one to
avoid creating the object each time

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

Not sure it's right to convert a formula to a value, at least not unless
specifically required to do so (I know you drew attention to it in the
comments).

Regards,
Peter T

VBA to superscript a part of a cell
 

On Fri, 16 Apr 2010 11:37:21 +0100, "Peter T" <peter_t@discussions wrote:

Couple of thoughts

Why not place these lines before the loop, particularly the first one to
avoid creating the object each time

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


Thanks for noticing that. When I first wrote the routine, it was for just a
single cell. And when I added the loop, having those lines inside was a
definite oversight.

Not sure it's right to convert a formula to a value, at least not unless
specifically required to do so (I know you drew attention to it in the
comments).

Yes, that's why I made it optional and added the comment in the text.

It occurred to me that, depending on how the OP "Populated" the range, it might
be done with formulas, as opposed to a Copy/Paste Values operation, and that he
should be aware that the superscripting cannot be easily done on other than
text strings (unless one had a superscripted font character that could be used
in a custom format).

Anyway, here's the routine with the object creation moved outside the loop, as
it should have been done the first time:

===============================
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

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

For Each c In Selection 'or in Range("B2:B15")

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
If c.HasFormula = True Then 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