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?

 

[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)
      [COLOR=#0000FF][B]If Len(Data(R, C)) Then[/B][/COLOR]
        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

One small change which should (untested) make the code ever so slightly faster...

Sub SuperScriptBetweenBackwardForwardSlashes()
  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)
      [B][COLOR=#0000FF]If Data(R, C) Like "*[/\]*" Then[/COLOR][/B]
        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[COLOR=#0000FF][/COLOR]

 

[Rick Rothstein]

One small change which should (untested) make the code ever so slightly faster...

Sub SuperScriptBetweenBackwardForwardSlashes()
  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)
      [COLOR=#000000]If Data(R, C) Like "*[/\]*" Then[/COLOR]
        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

Not wanting to give up on this question, here is a modification that will allow natural forward and/or backward slashes to be preserved while still letting them be used as delimiters for the subscripting. The method is to do what VB and Excel do for internal quote marks... double them up and after processing they will be converted to normal forward or backward slashes (that is use two adjacet forward or two adjacent backward slashes in the text where you want a single forward or backward slash to appear and that will happen after the code is run).

Sub SuperScriptBetweenBackwardForwardSlashes()
  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
  Application.ScreenUpdating = False
[COLOR=#0000FF][B]  ActiveSheet.UsedRange.Replace "//", Chr$(2), xlPart
  ActiveSheet.UsedRange.Replace "\\", Chr$(3), xlPart[/B][/COLOR]
  Data = Range("A1").Resize(Cells.Find("*", , xlValues, , xlRows, xlPrevious).Offset(1).Row, _
         Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Offset(, 1).Column)
  For R = 1 To UBound(Data)
    For C = 1 To UBound(Data, 2)
      If Data(R, C) Like "*[/\[B][COLOR=#0000FF]" & Chr$(2) & Chr$(3) & "[/COLOR][/B]]*" 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
[COLOR=#0000FF][B]          If Cells(R, C).Value Like "*[" & Chr$(2) & Chr$(3) & "]*" Then
            For X = 1 To Len(Cells(R, C).Value)
              If Mid(Cells(R, C).Value, X, 1) Like Chr$(2) Then
                Cells(R, C).Characters(X, 1).Text = "/"
              ElseIf Mid(Cells(R, C).Value, X, 1) Like Chr$(3) Then
                Cells(R, C).Characters(X, 1).Text = "\"
              End If
            Next
          End If[/B][/COLOR]
        End If
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub