3
\$\begingroup\$

I have material property entries in a cell those look something like this:

cell.value="O2 Permeability [cm^3/m^2]"

The goal is to format the numeric value after each ^ to be superscripted and to remove all ^.

Here my code:

Public Function FormatSuperscript(cell As Range) As Boolean
Dim i As Integer
Dim value As String
Dim cnum As New Collection
Dim num As Integer
Dim clen As New Collection

value = cell.value

num = 0

' first count the amount of ^

num = InStr(num + 1, value, "^")
If num <> 0 Then
    cnum.Add num
    ' count the length of the numeric entry
    clen.Add SuperScriptLength(value, num)
End If


While num <> 0
    num = InStr(num + 1, value, "^")
    If num <> 0 Then
        cnum.Add num
        ' count the length of the numeric entry
        clen.Add SuperScriptLength(value, num)
    End If
Wend

' remove all ^
cell.value = Replace(value, "^", vbNullString)

' go through all ^ places and superscript the length of the numeric entry from there on
For i = 1 To cnum.count
    cell.Characters(Start:=cnum(i) - i + 1, Length:=clen(i)).Font.Superscript = True
Next i

FormatSuperscript = True

End Function
Private Function SuperScriptLength(value As String, StartCharacter As Integer) As Integer
Dim s As String
Dim c As Integer
Dim i As Integer

c = 0
s = Right(value, Len(value) - StartCharacter)
While StringPop(s) = "-" Or IsNumeric(StringPop(s))
    c = c + 1
    s = Right(s, Len(s) - 1)
Wend

SuperScriptLength = c
End Function

Private Function StringPop(ByRef s As String) As String
StringPop = Left(s, 1)
End Function

Any suggestions on how to improve the run time on it?

\$\endgroup\$
3
\$\begingroup\$

Formatting individual characters in a string is relatively slow. My solution convert the exponents to superscript using Ascii and Unicode characters. This allows me to work with the values in an array and then write it back over the original range.

Using characters code took 0.79 seconds to process 10,000 cells compared to 42.05 using formatting individual characters. The file size increased by 14KB using the character codes and 50KB using character formatting.

Before                                                          After

Test Data Before Processing           Test Data After Processing

Code to Convert Exponents to SuperScript Characters

Function convertExponentsToSuperScript(Text As String, Optional ExponentChar As String = "^") As String
    If InStr(Text, ExponentChar) = 0 Then
        convertExponentsToSuperScript = Text
        Exit Function
    End If
    Dim newText() As String
    ReDim newText(Len(Text) - UBound(Split(Text, ExponentChar)))

    Dim exponentChars() As Variant
    exponentChars = Array(ChrW(&H2070), Chr(185), Chr(178), Chr(179), _
                          ChrW(&H2074), ChrW(&H2075), ChrW(&H2076), ChrW(&H2077), _
                          ChrW(&H2078), ChrW(&H2079))

    Dim textIndex As Long, newTextIndex As Long
    Dim ch As String
    Dim flag As Boolean

    For textIndex = 1 To Len(Text)
        ch = Mid(Text, textIndex, 1)
        If ch = ExponentChar Then
            flag = True
        Else
            newTextIndex = newTextIndex + 1
            If flag Then
                If IsNumeric(ch) Then
                    ch = exponentChars(ch)
                Else
                    flag = False
                End If
            End If

            newText(newTextIndex) = ch
        End If
    Next

    convertExponentsToSuperScript = Join(newText, "")
End Function

Test Code

Sub TestConvertExponentsToSuperScript()
    Dim target As Range
    Dim results As Variant
    Set target = Selection ' getTestRange(10000)
    results = target.value

    Dim t As Double: t = Timer

    Dim r As Long
    For r = 1 To UBound(results)
        results(r, 1) = convertExponentsToSuperScript(CStr(results(r, 1)))
    Next

    target.value = results

    Debug.Print Round(Timer - t, 2)
End Sub

Function getTestRange(TestRows As Long) As Range
    Dim results() As String
    ReDim results(1 To TestRows, 1 To 1)
    Dim r As Long
    For r = 1 To UBound(results)
        results(r, 1) = "O2 Permeability [cm^" & WorksheetFunction.RandBetween(0, 1000) & "/m^" & WorksheetFunction.RandBetween(0, 1000) & "]"
    Next
    Application.ScreenUpdating = False

    With Worksheets.Add
        .Range("A1") = "Test Data"
        With .Range("A2").Resize(UBound(results))
            .value = results
            Set getTestRange = .Cells
        End With
    End With
End Function
\$\endgroup\$
  • \$\begingroup\$ Works neato =) Upvote from me! \$\endgroup\$ – Lucas Raphael Pianegonda Dec 7 '18 at 10:03
  • \$\begingroup\$ Thanks for accepting my answer. A very interesting question \$\endgroup\$ – TinMan Dec 7 '18 at 10:18
  • 1
    \$\begingroup\$ Yeah, funny story.. one of my users came to me and was like : "What does this ^ mean? Shouldn't that be an exponent. Thats how I got to it. \$\endgroup\$ – Lucas Raphael Pianegonda Dec 7 '18 at 10:22
  • \$\begingroup\$ Plot twist: O2 should be O<sub>2</sub> ;-) \$\endgroup\$ – Mathieu Guindon Dec 12 '18 at 15:17
  • \$\begingroup\$ @MathieuGuindon hmmm.. I might adjust the code such that _ does subscript.. good idea. \$\endgroup\$ – Lucas Raphael Pianegonda Dec 12 '18 at 15:40

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.