VBA to superscript a part of a cell

  • Thread starter Thread starter Mikhail Bogorad
  • Start date Start date
M

Mikhail Bogorad

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
 
This is a sample of the syntax to accomplish the goal. Without knowing how
the data appears within your file, I cannot offer any more than this.

Range("B3").Characters(7, 2).Font.Superscript = True

This would re-format the seventh and eighth characters in the cell to
superscript. I am not sure how to find the occurrences in the file by
random search. Maybe somebody smarter than me will assist.
 
Try this in a normal module

Option Explicit
Sub Test()
Dim rng As Range
Dim cel As Range

On Error Resume Next
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If Not rng Is Nothing Then
For Each cel In rng
SuperNum cel
Next
End If
End Sub

Sub SuperNum(rCell As Range)
Dim n As Long, pos As Long
Dim s As String
Dim Target As Range
Dim vData, v, vFlag
Dim arr()

arr = Array("th", "st", "rd")
Set Target = Selection
If rCell.HasFormula = False Then
vData = rCell.Value
If VarType(vData) = vbString Then
vFlag = rCell.Font.Superscript

If IsNull(vFlag) Then vFlag = True
If vFlag Then rCell.Font.Superscript = False
s = rCell.Value
If Len(s) > 2 Then
For Each v In arr
pos = 0
pos = InStr(2, s, v)
If pos Then
n = Val(Mid$(s, pos - 1, 1))
If n Then
If pos + 1 < Len(s) Then
If Mid$(s, pos + 2, 1) <> " " Then n = 0
End If
End If
If n > 0 Then
rCell.Characters(pos, 2).Font.Superscript = True
Exit For
End If
End If
Next
End If
End If
End If
End Sub

Run Test() to process the active sheet

If you want changes to update immediately, try this in a worksheet module
(right - click sheet tab, view code)

Private Sub Worksheet_Change(ByVal Target As Range)
SuperNum Target(1)
End Sub

Regards,
Peter T
 
If I can anticipate your complete requirements (for 1st, 2nd, 3rd, nth),
give this macro a try after the cells have been filled in with their text...

Sub SuperScriptOrdinals()
Dim X As Long, NumPosition As Long, Cell As Range
For Each Cell In Range("B2:B15")
NumPosition = InStr(Cell.Value, "1st")
If NumPosition = 0 Then
NumPosition = InStr(Cell.Value, "2nd")
If NumPosition = 0 Then
NumPosition = InStr(Cell.Value, "3rd")
If NumPosition = 0 Then
For NumPosition = 1 To Len(Cell.Text)
If Mid(Cell.Value, NumPosition) Like "#th*" Then Exit For
Next
End If
End If
End If
If NumPosition Then
Cell.Characters(NumPosition + 1, 2).Font.Superscript = True
End If
Next
End Sub
 
If the text in the cell has one of your ordinals with an actual word before
the day number having that ordinal, then nothing will be superscripted. For
example, if the text were one of these, then nothing gets superscripted...

"Current start date is October 21st this year."

"August 1st begins the month."

"Hard start date: Jan 3rd."
 
Ah !
Gord - best bin my original...

FWIW, here's my original amended to cater for Rick's observations.

Sub SuperNum(rCell As Range)
Dim n As Long, pos As Long, start As Long
Dim s As String, sNum As String
Dim Target As Range
Dim vData, v, vFlag
Dim arr()

arr = Array("th", "1st", "2nd", "3rd")

Set Target = Selection
If rCell.HasFormula = False Then
vData = rCell.Value
If VarType(vData) = vbString Then
vFlag = rCell.Font.Superscript

If IsNull(vFlag) Then vFlag = True
If vFlag Then rCell.Font.Superscript = False
s = rCell.Value
If Len(s) > 2 Then
For Each v In arr
pos = 0
start = 2
pos = -1
While pos
pos = InStr(start, s, v)
If pos Then
sNum = Mid$(s, pos - 1, 1)

n = Val(Mid$(s, pos - 1, 1))

If n Then
If pos + 1 < Len(s) Then
If Mid$(s, pos + 2, 1) <> " " Then n = 0
End If
End If
If n > 0 Then
rCell.Characters(pos, 2).Font.Superscript =
True

pos = 0
End If
start = pos + 1
End If
Wend
If n Then Exit For
Next
End If
End If
End If
End Sub


Regards,
Peter T
 
Your testing was more thorough than mine Rick

I see what you mean after more testing.



Gord
 
If I can anticipate your complete requirements (for 1st, 2nd, 3rd, nth),
give this macro a try after the cells have been filled in with their text...

Sub SuperScriptOrdinals()
Dim X As Long, NumPosition As Long, Cell As Range
For Each Cell In Range("B2:B15")
NumPosition = InStr(Cell.Value, "1st")
If NumPosition = 0 Then
NumPosition = InStr(Cell.Value, "2nd")
If NumPosition = 0 Then
NumPosition = InStr(Cell.Value, "3rd")
If NumPosition = 0 Then
For NumPosition = 1 To Len(Cell.Text)
If Mid(Cell.Value, NumPosition) Like "#th*" Then Exit For
Next
End If
End If
End If
If NumPosition Then
Cell.Characters(NumPosition + 1, 2).Font.Superscript = True
End If
Next
End Sub
Click to expand...

As you write, you are trying to anticipate the complete requirements.

But I note that your routine does not completely error check for incorrect
suffixes. For example, May 21th would have the "th" superscripted.



--ron
 
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
Click to expand...

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
 
I had seen some code by Tom Ogilvy dealing with Ordinal numbers but nothing
with Superscript or Subscript. It was just adding the two digit ordinal
onto the numbers. I'll tuck this away for future reference. Thanks Peter.
 
JLGWhiz, afraid that wasn't quite right either! It didn't handle 11-13th
correctly, following also caters for multiple ordinals

test string
"August 1st, bend 2nd, third 3rd, 4th, 10th, 11th 101st 111th 4thousand"

Sub Test1()
Dim rng As Range
Dim cel As Range

On Error Resume Next
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If Not rng Is Nothing Then
For Each cel In rng
SuperNum cel
Next
End If
End Sub

Sub test2()
SuperNum ActiveCell
End Sub

Sub SuperNum(rCell As Range)
Dim n As Long, pos As Long, start As Long
Dim s As String, sNum As String
Dim Target As Range
Dim vData, v, vFlag
Dim arr()

arr = Array("th", "st", "nd", "rd")

Set Target = Selection
If rCell.HasFormula = False Then
vData = rCell.Value
If VarType(vData) = vbString Then
vFlag = rCell.Font.Superscript

If IsNull(vFlag) Then vFlag = True
If vFlag Then rCell.Font.Superscript = False
s = rCell.Value
If Len(s) > 2 Then
For Each v In arr
pos = 0
start = 2
pos = -1
While pos
pos = InStr(start, s, v)
If pos Then
sNum = Mid$(s, pos - 1, 1)

n = Val(sNum)
If n = 0 Then
If sNum = "0" Then n = -1
End If

If n Then
If pos + 1 < Len(s) Then
If Mid$(s, pos + 2, 1) _
Like "[ ,]" = False Then n = 0
End If
End If
If n Then
rCell.Characters(pos, 2).Font.Superscript =
True
End If
start = pos + 1
End If
Wend
Next
End If
End If
End If
End Sub

re Like "[ ,]"
include any other characters that might be allowed after an ordinal, such as
space or comma.

Looks like a lot of code but I think it should be the fastest approach here

Regards,
Peter T
 
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
Click to expand...

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
 
JLGWhiz, afraid that wasn't quite right either! It didn't handle 11-13th
correctly, following also caters for multiple ordinals

test string
"August 1st, bend 2nd, third 3rd, 4th, 10th, 11th 101st 111th 4thousand"

Sub Test1()
Dim rng As Range
Dim cel As Range

On Error Resume Next
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If Not rng Is Nothing Then
For Each cel In rng
SuperNum cel
Next
End If
End Sub

Sub test2()
SuperNum ActiveCell
End Sub

Sub SuperNum(rCell As Range)
Dim n As Long, pos As Long, start As Long
Dim s As String, sNum As String
Dim Target As Range
Dim vData, v, vFlag
Dim arr()

arr = Array("th", "st", "nd", "rd")

Set Target = Selection
If rCell.HasFormula = False Then
vData = rCell.Value
If VarType(vData) = vbString Then
vFlag = rCell.Font.Superscript

If IsNull(vFlag) Then vFlag = True
If vFlag Then rCell.Font.Superscript = False
s = rCell.Value
If Len(s) > 2 Then
For Each v In arr
pos = 0
start = 2
pos = -1
While pos
pos = InStr(start, s, v)
If pos Then
sNum = Mid$(s, pos - 1, 1)

n = Val(sNum)
If n = 0 Then
If sNum = "0" Then n = -1
End If

If n Then
If pos + 1 < Len(s) Then
If Mid$(s, pos + 2, 1) _
Like "[ ,]" = False Then n = 0
End If
End If
If n Then
rCell.Characters(pos, 2).Font.Superscript =
True
End If
start = pos + 1
End If
Wend
Next
End If
End If
End If
End Sub

re Like "[ ,]"
include any other characters that might be allowed after an ordinal, such as
space or comma.

Looks like a lot of code but I think it should be the fastest approach here

Regards,
Peter T
Click to expand...

This will superscript the ordinal even if it is not the correct one for the
value.

It also fails to recognize some legitimate constructs

E.g. Test strings

"101th vs 101st"
"May 21st-Jun 16th"




--ron
 
Ron Rosenfeld said:
JLGWhiz, afraid that wasn't quite right either! It didn't handle 11-13th
correctly, following also caters for multiple ordinals

test string
"August 1st, bend 2nd, third 3rd, 4th, 10th, 11th 101st 111th 4thousand"

Sub Test1()
Dim rng As Range
Dim cel As Range

On Error Resume Next
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If Not rng Is Nothing Then
For Each cel In rng
SuperNum cel
Next
End If
End Sub

Sub test2()
SuperNum ActiveCell
End Sub

Sub SuperNum(rCell As Range)
Dim n As Long, pos As Long, start As Long
Dim s As String, sNum As String
Dim Target As Range
Dim vData, v, vFlag
Dim arr()

arr = Array("th", "st", "nd", "rd")

Set Target = Selection
If rCell.HasFormula = False Then
vData = rCell.Value
If VarType(vData) = vbString Then
vFlag = rCell.Font.Superscript

If IsNull(vFlag) Then vFlag = True
If vFlag Then rCell.Font.Superscript = False
s = rCell.Value
If Len(s) > 2 Then
For Each v In arr
pos = 0
start = 2
pos = -1
While pos
pos = InStr(start, s, v)
If pos Then
sNum = Mid$(s, pos - 1, 1)

n = Val(sNum)
If n = 0 Then
If sNum = "0" Then n = -1
End If

If n Then
If pos + 1 < Len(s) Then
If Mid$(s, pos + 2, 1) _
Like "[ ,]" = False Then n = 0
End If
End If
If n Then
rCell.Characters(pos, 2).Font.Superscript
=
True
End If
start = pos + 1
End If
Wend
Next
End If
End If
End If
End Sub

re Like "[ ,]"
include any other characters that might be allowed after an ordinal, such
as
space or comma.

Looks like a lot of code but I think it should be the fastest approach
here

Regards,
Peter T
Click to expand...

This will superscript the ordinal even if it is not the correct one for
the
value.
Click to expand...

I had thought of that and could be adapted (the previous version did) but
thought probably not worth bothering with
It also fails to recognize some legitimate constructs

E.g. Test strings

"101th vs 101st"
"May 21st-Jun 16th"
Click to expand...

To cater for that particular one, ie the dash, amend the Like string as I
had suggested previously -

Like "[ ,-]" = False Then n = 0

Now let me pop over to yours and make a suggestion :-)

Regards,
Peter Thornton
 
Ron Rosenfeld said:
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
Click to expand...

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
 
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
Click to expand...

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).
Click to expand...

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
 
Thanks guys, i'll test your suggestions and let you know. In my report
it can only be "1st" no "2nd" or "3rd" but thanks anyways.
Click to expand...

In that case, the macro code can be reduced to this...

Sub SuperScriptOrdinals()
Dim X As Long, Position As Long, C As Range
For Each C In Range("B2:B15")
Position = InStr(C.Value, "1st")
If Position Then C.Characters(Position + 1, 2).Font.Superscript = True
Next
End Sub
 
Back
Top