Extract superscript and paste it into new column same row-CodePudding

I have been searching for a while now a code to help me to extract superscript characters (number 1 and 2) that are either in the middle or at the end of a string in column A. I need to cut them from the string and paste them into the same row, but on column C as a normal number. I did not find any suitable solutions I could evev try. So I do not have any code because I do not know where to start. My data will have always less than 500 lines and has the same structure, but lines with superscript change. Does anyone know to solve this problem please? Thanks a lot. I would really appreciate the help.

Desired output: for every row where there is a superscript, cut it from string in Column A and paste it in column C as a normal number..

CodePudding user response：

Let me know if the following works:

Option Explicit

Sub Test()

Application.ScreenUpdating = False

Dim wb As Workbook
Dim ws As Worksheet
Dim rngSuperscript As Range, c As Range

Dim iCount As Integer
Dim MyString As String

Set wb = ThisWorkbook
'Set it to sheet name where your data is
Set ws = wb.Sheets("Test")

'Change it to reflect your data
Set rngSuperscript = ws.Range("A2:A11")

For Each c In rngSuperscript
    'temp text variable
    MyString = c.Value
    
    'loop through the string value
    For iCount = 1 To Len(MyString)
    
    'checking if it is numeric value
    If IsNumeric(Mid(MyString, iCount, 1)) Then
        'combine with the next column value (if any)
        c.Offset(0, 1).Value = c.Offset(0, 1).Value & Mid(MyString, iCount, 1)
    End If
Next

Next c

Application.ScreenUpdating = True

End Sub

CodePudding user response：

Sub extractSuperscript()
    Dim rng As Range
    Dim cell As Range
    Dim i As Long
    Dim j As Long
    Dim result As String

    ' Define the range to process
    Set rng = Range("A1:A10")

    ' Loop through each cell in the range
    For i = 1 To rng.Cells.Count
        Set cell = rng.Cells(i)
        result = ""

        ' Loop through each character in the cell
        For j = 1 To Len(cell.Value)
            ' Check if the character is a superscript 1 or 2
            If Mid(cell.Value, j, 1) = "¹" Or Mid(cell.Value, j, 1) = "²" Then
                ' Add the character to the result string
                result = result & Mid(cell.Value, j, 1)
            End If
        Next j

        ' Paste the result string into column C
        cell.Offset(0, 2).Value = result
    Next i
End Sub

Let me know if this works