只在excel文件中找到子脚本和超级脚本，并用相同的unicode或符号替换它们。

Question

我们是老师，在excel文件中有很多化学，物理和数学的MCQ，有很多公式和方程式。当我们试图将这些MCQ导入到基于mySQL的数据库中时，公式中使用的所有下标和上标都丢失了，并被视为普通字符，例如，H2SO4，CO2，CH3等，并使我们的公式和元素命名为无意义。有没有什么解决方案可以让mySQL像从excel导入下标和上标一样？或者，有没有什么解决方案可以让我们用符号或unicode来代替excel中的下标和上标，因为mySQL可以直接选择符号和unicode？Rightnow现在我们正在用相同类型的符号/unicode手动替换子脚本和超级脚本，以便在导入到mysql中的web application.But后保持不变。完成这项繁重的任务将需要近两个月的时间。我们正在接受这个网站https://unicode-table.com/en/#superscripts-and-subscripts的帮助，所以请在这方面帮助我们。

首先，我试着问了一个问题，那就是如何将带有子脚本和超级脚本的excel导入到mysql中，这是我在社区中提出的第一个问题，但没有得到答案。

通过使用您提供的代码/方法/解决方案，只有在所有excel文件中找到的子脚本和超级脚本将被相同的unicode /符号字符替换，然后可以按原样导入到mysql中，并将在web上显示为与excel相同的内容，例如，H₂O in excel --> H₂O on web (2为unicode字符)

Answer 1

如果看不到数据和传输数据的方式，就很难给出答案。我怀疑这就是为什么你的帖子没有收到回复的原因。

我猜您的Excel公式很有可能被简单地格式化为子脚本和超级脚本字符，因此一种选择可能是在Excel本身中进行Unicode转换。

下面的代码应该可以让你上手了--不过，我相信你已经读过这个网站不是一个免费的代码编写服务，所以你需要修改它和/或扩展它来满足你自己的需要。它基本上创建了一个从属字符和上标字符到其Unicode等效项的映射，然后转换在映射中可以找到的任何字符。如果没有匹配，它会将字符涂成红色。

我想这对你来说是最简单的方法。您的另一种选择是在将每个项目写入数据库时对其进行转换，但是如果没有看到您的代码，我就无法为您生成一个可运行的示例。

祝好运。

Option Explicit

Public Sub RunMe()
    Dim ws As Worksheet
    Dim cell As Range
    Dim map As Collection, unresolveds As Collection
    Dim i As Long
    Dim str As String
    Dim v As Variant

    'Create the map of sub- and superscripts.
    Set map = GetScriptsMap

    'Create the output sheet.
    With ThisWorkbook.Worksheets
        Set ws = .Add(After:=.Item(.Count))
    End With

    'Iterate each cell in the range.
    For Each cell In Sheet1.UsedRange.Cells
        If cell.Characters.Count > 0 Then
            'Reset the collection of unresolved characters.
            Set unresolveds = New Collection
            'Iterate the text character by character.
            For i = 1 To cell.Characters.Count
                With cell.Characters(i, 1)
                    str = .Text
                    With .Font
                        'Check for sub- or superscript.
                        If .Subscript Or .Superscript Then
                            'Attempt a lookup of sub- or superscript characters.
                            'If the lookup fails, the str variable will hold its
                            'old .Text value.
                            On Error Resume Next
                            str = ChrW(map(str & IIf(.Subscript, "B", "P")))
                            'A failed lookup will return an error number,
                            'so add it to the collection of unresolved characters.
                            If Err.Number > 0 Then unresolveds.Add i
                            On Error GoTo 0
                        End If
                    End With
                End With
                'Build the output cell.
                With ws.Range(cell.Address)
                    .Value = .Value & str
                End With
            Next
            'Colour the unresolved characters red.
            For Each v In unresolveds
                ws.Range(cell.Address).Characters(v, 1).Font.Color = vbRed
            Next
        End If

    Next
End Sub

Private Function GetScriptsMap() As Collection
    Dim map As Collection

    Set map = New Collection

    'Superscript unicodes - key suffixed with 'P'
    map.Add &H2070, "0P"
    map.Add &H2071, "1P"
    map.Add &HB2, "2P"
    map.Add &HB3, "3P"
    map.Add &H2074, "4P"
    map.Add &H2075, "5P"
    map.Add &H2076, "6P"
    map.Add &H2077, "7P"
    map.Add &H2078, "8P"
    map.Add &H2079, "9P"
    map.Add &H207A, "+P"
    map.Add &H207B, "-P"
    map.Add &H207C, "=P"
    map.Add &H207D, "(P"
    map.Add &H207E, ")P"
    map.Add &H207F, "nP"
    'Subscript unicodes - key suffixed with 'B'
    map.Add &H2080, "0B"
    map.Add &H2081, "1B"
    map.Add &H2082, "2B"
    map.Add &H2083, "3B"
    map.Add &H2084, "4B"
    map.Add &H2085, "5B"
    map.Add &H2086, "6B"
    map.Add &H2087, "7B"
    map.Add &H2088, "8B"
    map.Add &H2089, "9B"
    map.Add &H208A, "+B"
    map.Add &H208B, "-B"
    map.Add &H208C, "=B"
    map.Add &H208D, "(B"
    map.Add &H208E, ")B"
    map.Add &H2090, "aB"
    map.Add &H2091, "eB"
    map.Add &H2092, "oB"
    map.Add &H2093, "xB"
    map.Add &H2094, ChrW(&H18F) & "B"
    map.Add &H2095, "hB"
    map.Add &H2096, "kB"
    map.Add &H2097, "lB"
    map.Add &H2098, "mB"
    map.Add &H2099, "nB"
    map.Add &H209A, "pB"
    map.Add &H209B, "sB"
    map.Add &H209C, "tB"

    Set GetScriptsMap = map
End Function

Answer 2

虽然@Ambie已经提出了一个构造良好的解决方案，也很好地解释了主题，但即使这样，我也只想分享我在这方面的线索和代码的细节。在这里，上下标Unicode字符将在名为“ScriptMap”的空白表格中空excel文件中列出。我使用Hex2DEC从十六进制Unicode值派生的列4,5的十进制值。该表格是从某些网站复制的(无法保证真实性)，可能会被修改和/或添加到自己的搜索结果中。

Chars   Uni Sup Uni Sub Dec Sup Dec Sub
0   2070    2080    8304    8320
1   00B9    2081    185 8321
2   00B2    2082    178 8322
3   00B3    2083    179 8323
4   2074    2084    8308    8324
5   2075    2085    8309    8325
6   2076    2086    8310    8326
7   2077    2087    8311    8327
8   2078    2088    8312    8328
9   2079    2089    8313    8329
a   1d43    2090    7491    8336
b   1d47        7495    0
c   1d9c        7580    0
d   1d48        7496    0
e   1d49    2091    7497    8337
f   1da0        7584    0
g   1d4d        7501    0
h   02b0    2095    688 8341
i   2071    1d62    8305    7522
j   02b2    2c7c    690 11388
k   1d4f    2096    7503    8342
l   02e1    2097    737 8343
m   1d50    2098    7504    8344
n   207f    2099    8319    8345
o   1d52    2092    7506    8338
p   1d56    209a    7510    8346
q           0   0
r   02b3    1d63    691 7523
s   02e2    209b    738 8347
t   1d57    209c    7511    8348
u   1d58    1d64    7512    7524
v   1d5b    1d65    7515    7525
w   02b7        695 0
x   02e3    2093    739 8339
y   02b8        696 0
z           0   0
A   1d2c        7468    0
B   1d2e        7470    0
C           0   0
D   1d30        7472    0
E   1d31        7473    0
F           0   0
G   1d33        7475    0
H   1d34        7476    0
I   1d35        7477    0
J   1d36        7478    0
K   1d37        7479    0
L   1d38        7480    0
M   1d39        7481    0
N   1d3a        7482    0
O   1d3c        7484    0
P   1d3e        7486    0
Q           0   0
R   1d3f        7487    0
S           0   0
T   1d40        7488    0
U   1d41        7489    0
V   2c7d        11389   0
W   1d42        7490    0
+   207A    208A    8314    8330
-   207B    208B    8315    8331
=   207C    208C    8316    8332
(   207D    208D    8317    8333
)   207E    208E    8318    8334

由于项目涉及多个excel文件，因此可以在开始执行代码时选择多个文件。它将遍历所有选定的文件、所有工作表和单元格。然而，我被延迟了，因为我对代码的速度/效率不满意。我发现它需要大约15分钟(在我的旧笔记本电脑上)来执行大约100个单元格的替换，每个单元格包含大约50个子标，在大约100×26个包含文本的单元格的使用范围内。刚开始的时候，我从100×26个单元格的文件开始，每个单元格包含大约50个子标，在执行过程中不得不中止跟踪。因此，如果文件的数量和子标的数量(以及使用的范围)非常大，则代码可能根本不可用。虽然我个人不喜欢保持计算，屏幕更新和enableEvents关闭，但这也不能显着提高速度。因此，我邀请进一步的答案，以提高速度/效率的类似操作。

代码(从包含工作表ScriptMap的空文件中添加并执行)：

Option Explicit
Sub ToUni()
Dim tm As Long
Dim Wb As Workbook, Ws As Worksheet, Rng As Range, Cel As Range
Dim Fname As Variant, Cha As Characters
Dim fl As FileDialog, ScrMap As Variant
Dim SupTxt As String
Dim i As Long, n As Long, UniNo As Long
tm = Timer
ScrMap = ThisWorkbook.Worksheets("ScriptMap").Range("A2:E65").Value 'modify to your requirement

'select files for conversion
Set fl = Application.FileDialog(msoFileDialogFilePicker)
With fl
  .AllowMultiSelect = True
  .InitialFileName = "C:\Temp\"
  .Filters.Clear
  .Filters.Add "All Excel Files", "*.xls*"
  .Show
End With

If fl.SelectedItems.Count <= 0 Then Exit Sub

   For Each Fname In fl.SelectedItems
   Set Wb = Workbooks.Open(Fname)
      For Each Ws In Wb.Worksheets
      Debug.Print Ws.Name
      Set Rng = Ws.UsedRange
        For Each Cel In Rng.Cells
        Debug.Print Cel.Address(False, False)
        If VarType(Cel.Value) = vbString Then
                For i = 1 To Cel.Characters.Count
                If Cel.Characters(i, 1).Font.Superscript Or Cel.Characters(i).Font.Subscript Then
                SupTxt = Cel.Characters(i, 1).Text

                    'Find unicode value of the char from ScrMap if avialable
                    For n = LBound(ScrMap, 1) To UBound(ScrMap, 1)
                    UniNo = 0

                        If SupTxt = ScrMap(n, 1) Then
                        If Cel.Characters(i, 1).Font.Superscript Then UniNo = ScrMap(n, 4)
                        If Cel.Characters(i, 1).Font.Subscript Then UniNo = ScrMap(n, 5)
                        End If
                    If UniNo > 0 Then Exit For
                    Next n

                    If UniNo > 0 Then
                    Cel.Characters(i, 1).Text = ChrW(UniNo)
                    'Debug.Print i, SupTxt, UniNo
                    End If

                End If
            Next i
        End If

        Next Cel
      Rng.Font.Superscript = False
      Rng.Font.Subscript = False
      Next Ws

   Debug.Print Wb.Path & "\" & Wb.Name
   Application.DisplayAlerts = False
   Wb.SaveAs Wb.Path & "\1converted_" & Wb.Name
   Wb.Close False
   Application.DisplayAlerts = True
   Next Fname
Debug.Print Timer - tm
End Sub

代码不会替换原始文件，而是通过在同一目录中的文件名中添加一些前缀来保存更改后的文件。