does anyone know how to encode subscripts?

[kylefoley76]

I need to write things like H2O in the Excel but 2 of course being subcripted. Does anyone know how to code for that in VBA?

 

[shg]

Ah -- two sets of unbalanced braces ...

 

[JoeMo]

Revised for generality ...

Shg: The IsBalanced function returns False for the typical chemical reaction below because the slash in 1/2 has no balancing backslash:

H/2\ + 1/2 O/2\ --> H/2\O

Rick: Why no closing backslash on P/1\Sn/2\C/3\Pb/4\ ?

 

[shg]

Once more:

Sub main()
    SubScr ActiveSheet.Cells
End Sub

Sub SubScr(rInp As Range)
    ' subscripts characters bracketed by open and closing braces
    ' ignores nesting

    Const sOpn      As String * 1 = "/"
    Const sCls      As String * 1 = "\"

    Dim rFind       As Range
    Dim sInp        As String
    Dim dic         As Object

    Dim ab()        As Boolean
    Dim b           As Boolean

    Dim sOut        As String
    Dim iRd         As Long
    Dim iWr         As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set rFind = rInp.Find(What:=sOpn, LookIn:=xlValues, LookAt:=xlPart)
    If Not rFind Is Nothing Then

        Do While Not rFind Is Nothing
            With rFind
                sInp = .Text
                If IsBalanced(sInp, sOpn, sCls) Then
                    iWr = 0
                    sOut = Replace(Replace(sInp, sOpn, ""), sCls, "")
                    ReDim ab(1 To Len(sOut))

                    For iRd = 1 To Len(sInp)
                        Select Case Mid(sInp, iRd, 1)
                            Case sOpn
                                b = True
                            Case sCls
                                b = False
                            Case Else
                                iWr = iWr + 1
                                ab(iWr) = b
                        End Select
                    Next iRd

                    .Value = sOut

                    For iWr = 1 To Len(sOut)
                        If ab(iWr) Then .Characters(iWr, 1).Font.Subscript = True
                    Next iWr

                Else
                    If dic.exists(.Address) Then Exit Do
                    dic.Add Key:=.Address, Item:=Nothing
                    .Interior.Color = vbYellow
                End If
            End With

            Set rFind = Cells.FindNext(rFind)
        Loop
    End If
End Sub

Function IsBalanced(sInp As String, sOpn As String, sCls As String) As Boolean
    ' returns True if sInp has balanced opening and closing braces

    Dim i           As Long
    Dim n           As Long

    For i = 1 To Len(sInp)
        Select Case Mid(sInp, i, 1)
            Case sOpn
                n = n + 1
            Case sCls
                n = n - 1
                If n < 0 Then Exit Function
        End Select
    Next i

    IsBalanced = n = 0
End Function

Thanks for the catch, Rick.

 

[shg]

Shg: The IsBalanced function returns False for the typical chemical reaction below because the slash in 1/2 has no balancing backslash:

H/2\ + 1/2 O/2\ --> H/2\O

You need to choose brace characters that are not otherwise used-- curly braces, brackets, whatever. Based on the OP's prior questions, I don't think this is about chemistry.

 

[JoeMo]

You need to choose brace characters that are not otherwise used-- curly braces, brackets, whatever. Based on the OP's prior questions, I don't think this is about chemistry.

Agreed, just wanted to give a a heads up for those who might want to apply such a nice piece of code to such cases.

 

[shg]

Fair point, Joe

In a related vein, the code doesn't support subscrpting either of the brace characters.

 

[Rick Rothstein]

Rick: Why no closing backslash on P/1\Sn/2\C/3\Pb/4\ ?

An assumed mistake in the data... that is what I assumed shg was "trapping" with the color-it-yellow part of his code.

 

[shg]

In the last code posted, this ...

Set rFind = Cells.FindNext(rFind)

... should be ...

Set rFind = rInp.FindNext(rFind)

 

[shg]

Testing is underrated ...

Sub main()
    SubScr ActiveSheet.Cells
End Sub

Sub SubScr(rInp As Range)
    ' subscripts characters bracketed by open and closing braces
    ' ignores nesting

    Const sOpn      As String * 1 = "/"
    Const sCls      As String * 1 = "\"

    Dim rFind       As Range
    Dim sInp        As String
    Dim dic         As Object

    Dim ab()        As Boolean
    Dim b           As Boolean

    Dim sOut        As String
    Dim iRd         As Long
    Dim iWr         As Long

    Set dic = CreateObject("Scripting.Dictionary")
    Set rFind = rInp.Find(What:=sOpn, LookIn:=xlValues, LookAt:=xlPart)
    
    Do While Not rFind Is Nothing
        With rFind
            sInp = .Text
            If IsBalanced(sInp, sOpn, sCls) Then
                iWr = 0
                sOut = Replace(Replace(sInp, sOpn, ""), sCls, "")
                ReDim ab(1 To Len(sOut))

                For iRd = 1 To Len(sInp)
                    Select Case Mid(sInp, iRd, 1)
                        Case sOpn
                            b = True
                        Case sCls
                            b = False
                        Case Else
                            iWr = iWr + 1
                            ab(iWr) = b
                    End Select
                Next iRd

                .Value = sOut

                For iWr = 1 To Len(sOut)
                    If ab(iWr) Then .Characters(iWr, 1).Font.Subscript = True
                Next iWr

            Else
                If dic.exists(.Address) Then Exit Do
                dic.Add Key:=.Address, Item:=Nothing
                .Interior.Color = vbYellow
            End If
        End With

        Set rFind = rInp.FindNext(rFind)
    Loop
End Sub

Function IsBalanced(sInp As String, sOpn As String, sCls As String) As Boolean
    ' returns True if sInp has balanced opening and closing braces

    Dim i           As Long
    Dim n           As Long

    For i = 1 To Len(sInp)
        Select Case Mid(sInp, i, 1)
            Case sOpn
                n = n + 1
            Case sCls
                n = n - 1
                If n < 0 Then Exit For
        End Select
    Next i

    IsBalanced = n = 0
End Function

 

[Rick Rothstein]

Here is my take on coding for this question (it does like shg's code and marks improperly formed text yellow)...

Sub SubscriptBetweenBackwardForwardSlashes()
  Dim X As Long, R As Long, C As Long, BS As Long, FS As Long, Data As Variant, Temp As String
  If ActiveSheet.UsedRange.Address(0, 0) = "A1" And Len(Range("A1").Value) = 0 Then Exit Sub
  Data = Range("A1").Resize(Cells.Find("*", , xlValues, , xlRows, xlPrevious).Offset(1).Row, _
         Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Offset(, 1).Column)
  Application.ScreenUpdating = False
  For R = 1 To UBound(Data)
    For C = 1 To UBound(Data, 2)
      If Len(Data(R, C)) Then
        Temp = Data(R, C)
        For X = 1 To Len(Temp)
          If Mid(Temp, X, 1) Like "[!/\]" Then Mid(Temp, X, 1) = " "
        Next
        Temp = Replace(Temp, " ", "")
        If Temp Like "*//*" Or Temp Like "*\\*" Or UBound(Split(Temp, "/")) <> UBound(Split(Temp, "\")) Then
          Cells(R, C).Interior.ColorIndex = 6
        Else
          FS = InStrRev(Cells(R, C).Value, "/")
          Do While FS
            BS = InStr(FS, Cells(R, C).Value, "\")
            Cells(R, C).Characters(FS, BS - FS + 1).Text = Cells(R, C).Characters(FS + 1, BS - FS - 1).Text
            Cells(R, C).Characters(FS, BS - FS - 1).Font.Subscript = True
            FS = InStrRev(Cells(R, C).Value, "/", FS - 1)
          Loop
        End If
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub