Display the difference between two cells in excel status bar - vba

Question

I was looking for code to determine the difference between two selected cells and display it in the status bar of Excel 2010.
I found some code, but it applies only to the workbook that contains that code.
Is it possible to make this code functional on every workbook I am working with?
It would be great if this kind of code runs automatically like macros from personal.xlsb.
Public Sub workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
Set sh = ActiveSheet
If Selection.Cells.Count = 2 Then
On Error Resume Next
If WorksheetFunction.Count(Range(Selection.Address)) = 2 Then
Application.StatusBar = "The difference is " & _
WorksheetFunction.Max(Range(Selection.Address)) _
- WorksheetFunction.Min(Range(Selection.Address))
Else
Application.StatusBar = "The difference is " & _
WorksheetFunction.Max(Range(Selection.Address))
End If
Else
Application.StatusBar = False
End If
End Sub

Answer 1

I found some code, but it applies only to the workbook that contains that code. Is it possible to make this code functional on every workbook I am working with?
You will have to create an Add-In for this. And then place this in your Add-In's ThisWorkbook module. After the Add-In has been created, activate it by checking its check-box on the Developer Tab, Add-Ins Section.
Private WithEvents oXLApp As Excel.Application
Private Sub Workbook_Open()
Set oXLApp = Excel.Application
End Sub
Private Sub oXLApp_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
'
'~~> Rest of the code here
'
End Sub

Answer 2

These question resulted in the following tool.
Save the following project as .xla
Thisworkbook:
Private WithEvents oXLApp As Excel.Application
Private Sub Workbook_Open()
Set oXLApp = Excel.Application
End Sub
Private Sub oXLApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As range)
Dim limit As Long
limit = 300000 ' selection limit
Dim frmt As String
frmt = "#,##0;(#,##0);""-""" ' formating at status bar
' first condition - one selection area
If Selection.Areas.Count = 1 Then
On Error Resume Next
If Selection.Cells.Count > 1 And Selection.Cells.Count < limit Then
On Error Resume Next
Application.StatusBar = _
" D: " & Format(WorksheetFunction.Max(Selection) - WorksheetFunction.Min(Selection), frmt) & _
" U: " & Format(Unique(Selection), frmt) & _
" 2X: " & Format(WorksheetFunction.Sum(Selection) * 2, frmt) & _
" X2: " & Format(WorksheetFunction.Sum(Selection) / 2, frmt) & _
" NC: " & Format(WorksheetFunction.CountIf(Selection, "<0"), frmt) & _
" NS: " & Format(WorksheetFunction.SumIf(Selection, "<0"), frmt)
Else
If Selection.Cells.Count = 1 Or Selection.Cells.Count >= limit Then
On Error Resume Next
Application.StatusBar = False
End If ' No condition
End If ' Cells > 2 and < limit
End If ' Areas = 1 - end of first condition
' second condition - more than one selection areas
If Selection.Areas.Count > 1 Then
Dim r1 As range
Dim r2 As range
Set r1 = Selection.Areas(1)
'WorksheetFunction.Sum (r1)
On Error Resume Next
Set r2 = Selection.Areas(2)
'Set multipleRange = Union(r1, r2)
On Error Resume Next
If Selection.Cells.Count > 1 And Selection.Cells.Count < limit Then
On Error Resume Next
Application.StatusBar = _
" D: " & Format(DIFF(r1, r2), frmt) & _
" U: " & Format(Unique(r1), frmt) & _
" 2X: " & Format(WorksheetFunction.Sum(r1) * 2, frmt) & _
" X2: " & Format(WorksheetFunction.Sum(r1) / 2, frmt) & _
" NC: " & Format(WorksheetFunction.CountIf(r1, "<0"), frmt) & _
" NS: " & Format(WorksheetFunction.SumIf(r1, "<0"), frmt)
Else
If Selection.Cells.Count = 1 Or Selection.Cells.Count >= limit Then
On Error Resume Next
Application.StatusBar = False
End If ' no condition
End If ' Cells > 1
End If ' Areas > 1 - end of second condition
End Sub
Module 1:
Public Function DIFF(rng1 As range, rng2 As range)
DIFF = WorksheetFunction.Sum(rng1) - WorksheetFunction.Sum(rng2)
End Function
Module 2:
Public Function Unique(ByRef rngToCheck As range) As Variant
Dim colDistinct As Collection
Dim varValues As Variant, varValue As Variant
Dim lngCount As Long, lngRow As Long, lngCol As Long
On Error GoTo ErrorHandler
varValues = rngToCheck.Value
'if rngToCheck is more than 1 cell then
'varValues will be a 2 dimensional array
If IsArray(varValues) Then
Set colDistinct = New Collection
For lngRow = LBound(varValues, 1) To UBound(varValues, 1)
For lngCol = LBound(varValues, 2) To UBound(varValues, 2)
varValue = varValues(lngRow, lngCol)
'ignore blank cells and throw error
'if cell contains an error value
If LenB(varValue) > 0 Then
'if the item already exists then an error will
'be thrown which we want to ignore
On Error Resume Next
colDistinct.Add vbNullString, CStr(varValue)
On Error GoTo ErrorHandler
End If
Next lngCol
Next lngRow
lngCount = colDistinct.Count
Else
If LenB(varValues) > 0 Then
lngCount = 1
End If
End If
Unique = lngCount
Exit Function
ErrorHandler:
Unique = CVErr(xlErrValue)
End Function