Option Explicit
Private Type TypeArguments
Action As Long
Cells As Excel.Range
Caller As Range
Formula As String
WithFontColor As Boolean
WithBackgroundColor As Boolean
DisplayFormat As Boolean
IsCount As Boolean
Value As Variant
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
Sub test()
On Error Resume Next
Dim k%, u%
u = UBound(Works)
For k = 1 To u
Debug.Print Works(k).Action
Next
End Sub
Function S_CountF( _
ByVal Cells As Range, _
Optional ByVal WithFontColor As Boolean = True, _
Optional ByVal WithBackgroundColor As Boolean = True, _
Optional ByVal DisplayFormat As Boolean = True, _
Optional ByVal Title$ = vbNullChar)
On Error Resume Next
Dim r As Object, k%, n%, i%, s$, f$, t$
t = "T" & ChrW(7893) & "ng " & ChrW(273) & ChrW(7871) & "m: "
s = Cells.Address(0, 0)
Set r = Application.Caller
f = r.Formula
If WithFontColor = False And WithBackgroundColor = False Then
S_CountF = t & "Ch" & ChrW(7885) & "n " & ChrW(273) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n m" & ChrW(224) & "u ph" & ChrW(244) & "ng + n" & ChrW(7873) & "n"
Exit Function
Else
If Title = vbNullChar Then
S_CountF = t
Else
S_CountF = Title
End If
End If
If Cells.Worksheet.ProtectContents Then
S_CountF = "Protect"
Exit Function
End If
k = UBound(Works)
For i = 1 To k
With Works(i)
If .Formula = f Then
Select Case .Action
Case 2: S_CountF = t & .Value: .Action = 3:
S_SumOrCount_finish k
Exit Function
Case Else: .Action = 0: GoTo n
End Select
Exit For
End If
End With
Next
k = k + 1
ReDim Preserve Works(1 To k)
With Works(k)
Set .Caller = r
Set .Cells = Cells
.Formula = f
.WithFontColor = WithFontColor
.WithBackgroundColor = WithBackgroundColor
.DisplayFormat = DisplayFormat
.IsCount = True
End With
n:
Set r = Nothing
If gTimerID = 0 Then
gTimerID = SetTimer(0&, 0&, 0, AddressOf S_SumOrCount_callback)
End If
On Error GoTo 0
End Function
Function S_SumF( _
ByVal Cells As Range, _
Optional ByVal WithFontColor As Boolean = True, _
Optional ByVal WithBackgroundColor As Boolean = True, _
Optional ByVal DisplayFormat As Boolean = True, _
Optional ByVal Title$ = vbNullChar)
On Error Resume Next
Dim r As Object, k%, n%, i%, s$, f$, t$
t = "T" & ChrW(7893) & "ng: "
s = Cells.Address(0, 0)
Set r = Application.Caller
f = r.Formula
If WithFontColor = False And WithBackgroundColor = False Then
S_SumF = t & "Ch" & ChrW(7885) & "n " & ChrW(273) & "i" & ChrW(7873) & "u ki" & ChrW(7879) & "n m" & ChrW(224) & "u ph" & ChrW(244) & "ng + n" & ChrW(7873) & "n"
Exit Function
Else
If Title = vbNullChar Then
S_SumF = t
Else
S_SumF = Title
End If
End If
If Cells.Worksheet.ProtectContents = True Then
S_SumF = "Protect"
Exit Function
End If
k = UBound(Works)
For i = 1 To k
With Works(i)
If .Formula = f Then
Select Case .Action
Case 2: S_SumF = t & .Value:
.Action = 3
S_SumOrCount_finish k
Exit Function
Case Else:
.Action = 0: GoTo n
End Select
Exit For
End If
End With
Next
k = k + 1
ReDim Preserve Works(1 To k)
With Works(k)
Set .Caller = r
Set .Cells = Cells
.Formula = f
.WithFontColor = WithFontColor
.WithBackgroundColor = WithBackgroundColor
.DisplayFormat = DisplayFormat
.IsCount = False
End With
n:
Set r = Nothing
If gTimerID = 0 Then
gTimerID = SetTimer(0&, 0&, 0, AddressOf S_SumOrCount_callback)
End If
On Error GoTo 0
End Function
Private Sub S_SumOrCount_finish(ByVal u%)
Dim k%
For k = 1 To u
If Works(k).Action <> 3 Then
Exit Sub
End If
Next
If u > 0 Then
Erase Works
End If
End Sub
Private Sub S_SumOrCount_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID)
gTimerID = 0
S_SumOrCount_working
On Error GoTo 0
End Sub
Private Sub S_SumOrCount_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
Call S_CountOrSum(b.Cells, b.Caller, b.WithFontColor, b.WithBackgroundColor, b.DisplayFormat, b.IsCount, v)
Works(i).Action = 2
Works(i).Value = v
b.Caller.Formula = b.Formula
Else
Works(i).Action = 3
End If
Case 3, 4: 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 S_Cells(ParamArray Cells()) As Range
Dim c, r As Range
For Each c In Cells
If TypeName(c) = "Range" Then
If r Is Nothing Then
Set r = c
Else
If r.Parent Is c.Parent Then
Set r = Union(c, r)
End If
End If
End If
Next
Set S_Cells = r
End Function
Private Sub S_CountOrSum( _
ByVal Cells As Range, _
ByVal Caller As Range, _
Optional ByVal WithFontColor As Boolean = True, _
Optional ByVal WithBackgroundColor As Boolean = True, _
Optional ByVal DisplayFormat As Boolean = True, _
Optional ByVal IsCount As Boolean, _
Optional Value As Variant)
Dim r&, v, c$, c1&, c2&, cell, mCell, cs As Range, w As Worksheet
Dim cl(), it%, z%, m As Boolean, n As Boolean
Dim d As Object
Set d = VBA.CreateObject("Scripting.Dictionary")
Value = 0
For Each cell In Cells
Set mCell = cell.MergeArea
m = False
If w Is Nothing Then
m = True
Set cs = mCell
GoSub c
Set w = cell.Parent
Else
GoSub r
End If
If m Then
If DisplayFormat Then
c1 = cell.DisplayFormat.Interior.Color
c2 = cell.DisplayFormat.font.Color
Else
c1 = cell.Interior.Color
c2 = cell.font.Color
End If
c = IIf(WithBackgroundColor, c1, vbNullString) & "a" & _
IIf(WithFontColor, c2, vbNullString)
If IsCount Then
If d.exists(c) Then
d(c) = Array(d(c)(0) + 1, d(c)(1), d(c)(2))
Else
d.Add c, Array(1, c1, c2)
End If
Value = Value + 1
Else
v = cell.Value
n = IsNumeric(v)
If n Then
Value = Value + v
End If
If d.exists(c) Then
If n Then
v = d(c)(0) + v
d(c) = Array(v, d(c)(1), d(c)(2))
End If
Else
If n Then
d.Add c, Array(v, c1, c2)
End If
End If
End If
End If
Next
If d.Count Then
r = 1
For Each cell In d.keys()
r = r + 1
With Caller(r, 1)
.Interior.Color = d(cell)(1)
.font.Color = d(cell)(2)
.Value = d(cell)(0)
End With
Next
End If
Set cell = Caller(2, 1)
r = cell(1000, 1).End(xlUp).Row - cell.Row + 1
If r > 0 And r - d.Count > 0 Then
cell(r + 1, 1).Copy cell(d.Count + 1, 1).Resize(r - d.Count, 1)
End If
Set d = Nothing
Set w = Nothing
Set cs = Nothing
Exit Sub
r:
If w Is cell.Parent Then
m = Intersect(cs, mCell) Is Nothing
Set cs = Union(cs, mCell)
Else
m = True
For it = 1 To w
If cl(1, it) Is cell.Parent Then
Set cs = cl(2, it): m = False
Exit For
End If
Next
If m Then
Set cs = mCell
Set w = cell.Parent
GoSub c
Else
m = Intersect(cs, mCell) Is Nothing
End If
End If
Return
c:
z = z + 1
ReDim Preserve cl(1 To 2, 1 To z)
Set cl(1, z) = cell.Parent
Set cl(2, z) = cs
Return
End Sub
