夜雨聆风
Excel化学式排版宏代码,一键消除各种乱码!(用浏览器打开本推文复制代码)
Sub Yajie_Excel_ChemFormatter_Pro()
‘ ======================================================================
‘ 【独家原创】Excel 专属 LaTeX 化学式一键粘贴排版
‘ Author: yajie日记 @What a KUN
‘ ======================================================================
Dim KUN_Trace_ID As String
KUN_Trace_ID = “Auth:Yajie_Dairy|Core:What_a_KUN|Ver:Final_Pro_Compact”
‘ ——————————————
Dim cell As Range, targetCell As Range
Dim clipTxt As String
Dim res As String
Dim charFormats() As Integer
Dim i As Long, j As Long, p As Long, k As Integer
Dim c As String, nextC As String
Dim mode As Integer
Dim isSingleCharMode As Boolean
Dim arrRows() As String
Dim arrCols() As String
Dim r As Long, col As Long
Dim cellText As String
Dim pos As Long, posClose As Long
If TypeName(Selection) <> “Range” Then
MsgBox “请先单击选中一个空白单元格！”, vbCritical, “What a KUN 提示”
Exit Sub
End If
Set cell = ActiveCell
On Error Resume Next
clipTxt = CreateObject(“htmlfile”).ParentWindow.ClipboardData.GetData(“Text”)
On Error GoTo 0
If Len(clipTxt) = 0 Then
MsgBox “剪贴板是空的，请先去复制文本或表格！”, vbExclamation, “提示”
Exit Sub
End If
Application.ScreenUpdating = False
clipTxt = Replace(clipTxt, Chr(0), “”)
clipTxt = Replace(clipTxt, “~”, ” “)
Dim arrFind As Variant, arrRep As Variant
arrFind = Array(“\leftrightarrow”, “\rightleftharpoons”, “\rightarrow”, “\bullet”, “\cdot”, “\times”, “\sim”, “\alpha”, “\beta”, “\gamma”, “\mu”, “\Delta”, “\delta”, “\theta”, “\pi”, “\circ”, “\pm”, “\leq”, “\geq”, “\approx”, “\lambda”, “\sigma”, “\omega”, “\varepsilon”)
arrRep = Array(ChrW(8596), ChrW(8652), ChrW(8594), ChrW(8226), ChrW(183), ChrW(215), “~”, ChrW(945), ChrW(946), ChrW(947), ChrW(956), ChrW(916), ChrW(948), ChrW(952), ChrW(960), ChrW(176), ChrW(177), ChrW(8804), ChrW(8805), ChrW(8776), ChrW(955), ChrW(963), ChrW(969), ChrW(949))
For k = LBound(arrFind) To UBound(arrFind)
clipTxt = Replace(clipTxt, arrFind(k) & ” “, arrRep(k))
clipTxt = Replace(clipTxt, arrFind(k), arrRep(k))
Next k
clipTxt = Replace(clipTxt, “$”, “”)
pos = InStr(clipTxt, “\text{“)
Do While pos > 0
posClose = InStr(pos, clipTxt, “}”)
If posClose > 0 Then
clipTxt = Left(clipTxt, posClose – 1) & Mid(clipTxt, posClose + 1)
clipTxt = Left(clipTxt, pos – 1) & Mid(clipTxt, pos + 6)
Else
clipTxt = Replace(clipTxt, “\text{“, “”)
End If
pos = InStr(clipTxt, “\text{“)
Loop
clipTxt = Replace(clipTxt, vbCrLf, vbLf)
clipTxt = Replace(clipTxt, vbCr, vbLf)
Do While InStr(clipTxt, vbLf & vbLf) > 0
clipTxt = Replace(clipTxt, vbLf & vbLf, vbLf)
Loop
Dim isSingleCellMode As Boolean
isSingleCellMode = False
If InStr(clipTxt, vbTab) = 0 And InStr(clipTxt, vbLf) > 0 Then
isSingleCellMode = True
End If
If Right(clipTxt, 1) = vbLf Then clipTxt = Left(clipTxt, Len(clipTxt) – 1)
If Left(clipTxt, 1) = vbLf Then clipTxt = Mid(clipTxt, 2)
If isSingleCellMode Then
ReDim arrRows(0)
arrRows(0) = clipTxt
Else
arrRows = Split(clipTxt, vbLf)
End If
For r = 0 To UBound(arrRows)
arrCols = Split(arrRows(r), vbTab)
For col = 0 To UBound(arrCols)
cellText = arrCols(col)
Set targetCell = cell.Offset(r, col)
If Len(cellText) > 0 Then
res = “”
ReDim charFormats(1 To Len(cellText))
p = 1
j = 0
mode = 0
isSingleCharMode = False
While p <= Len(cellText)
c = Mid(cellText, p, 1)
If p < Len(cellText) Then nextC = Mid(cellText, p + 1, 1) Else nextC = “”
If c = “_” Then
mode = 1
If nextC <> “{” Then isSingleCharMode = True
p = p + 1
ElseIf c = “^” Then
mode = 2
If nextC <> “{” Then isSingleCharMode = True
p = p + 1
ElseIf c = “{” Then
isSingleCharMode = False
p = p + 1
ElseIf c = “}” Then
mode = 0
p = p + 1
Else
j = j + 1
res = res & c
charFormats(j) = mode
If isSingleCharMode Then
mode = 0
isSingleCharMode = False
End If
p = p + 1
End If
Wend
targetCell.NumberFormat = “@”
targetCell.Value = res
If isSingleCellMode Then targetCell.WrapText = True
For i = 1 To j
If charFormats(i) = 1 Then targetCell.Characters(i, 1).Font.Subscript = True
If charFormats(i) = 2 Then targetCell.Characters(i, 1).Font.Superscript = True
Next i
End If
Next col
Next r
Application.ScreenUpdating = True
End Sub