Option Explicit
Private Type TypeArguments
Action As Long
Cells As Excel.Range
Caller As Range
Formula As String
End Type
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
''///////////////////////////////////////////////////////
#If VBA7 And Win64 Then
Private gTimerID As LongPtr
#Else
Private gTimerID As Long
#End If
''///////////////////////////////////////////////////////
Private Works() As TypeArguments
Function S_ReplaceE(ByVal Cells As Range)
On Error Resume Next
S_ReplaceE = ReplaceE(Cells(1, 1).Value)
Dim r As Object, k%, n%, i%, s$, f$
s = Cells.Address(0, 0)
Set r = Application.Caller
f = r.Formula
k = UBound(Works)
k = k + 1
ReDim Preserve Works(1 To k)
With Works(k)
Set .Caller = r
Set .Cells = Cells
.Formula = f
End With
n:
Set r = Nothing
If gTimerID = 0 Then
gTimerID = SetTimer(0&, 0&, 0, AddressOf S_ReplaceE_callback)
End If
On Error GoTo 0
End Function
Private Sub S_ReplaceE_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID)
gTimerID = 0
S_ReplaceE_working
On Error GoTo 0
End Sub
Private Sub S_ReplaceE_working()
On Error Resume Next
Dim UB As Integer, a As Object, b As TypeArguments, i&, k&, su As Boolean, Ac As Boolean, v As Variant
UB = UBound(Works)
Dim s$
For i = 1 To UB
b = Works(i)
Select Case b.Action
Case 0
If b.Caller.Formula = b.Formula Then
If a Is Nothing Then
Set a = b.Cells.Parent.Parent.Parent
su = a.ScreenUpdating
Ac = a.Calculation
If su Then a.ScreenUpdating = False
If Ac = xlCalculationAutomatic Then a.Calculation = xlCalculationManual
End If
Works(i).Action = 1
Dim r, c, c2, d
c = b.Cells.Rows.Count
r = b.Cells(c + 10, 1).End(3).Row - b.Cells(2, 1).Row + 1
If r > 0 Then
c = r
d = b.Cells(2, 1).Resize(c + 1000, b.Cells.Columns.Count).Value
For r = 1 To c
For c2 = 1 To UBound(d, 2)
d(r, c2) = ReplaceE(d(r, c2))
Next
Next
b.Caller(2, 1).Resize(UBound(d), UBound(d, 2)).Value = d
End If
Else
Works(i).Action = 3
End If
k = k + 1
End Select
n:
Next
If k >= UB Then
Erase Works
End If
If Not a Is Nothing Then
If su And a.ScreenUpdating <> su Then
a.ScreenUpdating = su
End If
If Ac = xlCalculationAutomatic And Ac <> a.Calculation Then
a.Calculation = Ac
End If
Set a = Nothing
End If
On Error GoTo 0
End Sub
Function ReplaceE(ByVal Text)
Dim l, s
l = Len(Text)
If l >= 2 Then
Text = Left(Text, l - 2) & VBA.Replace(Text, "mm", "mm", l - 1, 1, 1)
s = Split(Text, " ")
s(UBound(s)) = VBA.Replace(s(UBound(s)), "x", "x", , , 1)
Text = Join(s, " ")
End If
ReplaceE = Text
End Function
