Private Sub Worksheet_Calculate()
'
' V1.0
' 1st 10 minute refresh will create the destination if it doesn't exist & will save the Formula column results to create a base line to compare to.
' All other 10 minute refreshes will compare the current formula column to the previous formula column and display the row #s that changed to '1' or '-1'.
'
' Check the lines at the top of the script that end with ' <---
' Those lines are the lines that may need to be changed to reflect your particular setup.
'
'
Dim FormulaStartRow As Long, LastRowValue1 As Long
Dim FormulaColumn As String, Value1Column As String
'
FormulaColumn = "E" ' <--- Set this to the formula Column letter
FormulaStartRow = 2 ' <--- Set this to the start row of formulas in the FormulaColumn
Value1Column = "B" ' <--- Set this to the Value1 Column letter, this column is used to determine last row
'
LastRowValue1 = Range(Value1Column & Rows.Count).End(xlUp).Row ' Determine last row of data
'
If Application.CountIf(Range(FormulaColumn & FormulaStartRow & _
":" & FormulaColumn & LastRowValue1), "1") > 0 Or _
Application.CountIf(Range(FormulaColumn & FormulaStartRow & _
":" & FormulaColumn & LastRowValue1), "-1") > 0 Then ' If the range contains any value of 1 or -1 then ...
'
Dim DestinationSheetExists As Boolean
Dim FormulaColumnRow As Long, OutputArrayRow As Long
Dim LastDestinationColumnNumber As Long
Dim RowOffset As Long
Dim DestinationSheet As String
Dim FormulaColumnArray As Variant, OutputArray As Variant, PreviousFormulaResultArray As Variant
Dim wsDestination As Worksheet, wsSource As Worksheet
'
DestinationSheet = "TenMinuteUpdates" ' <--- Set this to the name of the sheet to store 10 minute results into
Set wsSource = Sheets("Sheet1") ' <--- Set this to the sheetname that has the '1's & '0's
'
On Error Resume Next ' Bypass error generated in next line if sheet does not exist
Set wsDestination = Sheets(DestinationSheet) ' Assign DestinationSheet to wsDestination
On Error GoTo 0 ' Turn Excel error handling back on
'
If Not wsDestination Is Nothing Then DestinationSheetExists = True ' Check to see if the DestinationSheet exists
'
' Create DestinationSheet if it doesn't exist
If DestinationSheetExists = False Then ' If DestinationSheet does not exist then ...
Sheets.Add(After:=wsSource).Name = DestinationSheet ' Create the DestinationSheet after the Source sheet
Set wsDestination = Sheets(DestinationSheet) ' Assign the DestinationSheet to wsDestination
End If
'
FormulaColumnArray = wsSource.Range(FormulaColumn & _
FormulaStartRow & ":" & FormulaColumn & LastRowValue1) ' Save the values of the formula Column range into the 2D 1 based FormulaColumnArray RC
'
ReDim OutputArray(1 To UBound(FormulaColumnArray)) ' Establish # of rows in 1D 1 based OutputArray
'
' Create Saved formula result column on DestinationSheet
If wsDestination.Range("A1") = vbNullString Then
wsDestination.Range("A1") = Date ' Display the Date on DestinationSheet
wsDestination.Range("A2") = Time() ' Display the Time on DestinationSheet
wsDestination.Range("A3") = "------------------" ' Display spacer line on DestinationSheet
'
wsDestination.Range("A4").Resize(UBound(FormulaColumnArray)) = _
FormulaColumnArray ' Display results to DestinationSheet
'
wsDestination.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns
'
GoTo SubExit
End If
'
PreviousFormulaResultArray = wsDestination.Range("A4:A" & _
wsDestination.Range("A" & Rows.Count).End(xlUp).Row) ' Load previous formula results into PreviousFormulaResultArray
'
OutputArrayRow = 0 ' Initialize OutputArrayRow to zero
RowOffset = FormulaStartRow - LBound(FormulaColumnArray) ' Determine Row difference between FormulaStartRow and start row of FormulaColumnArray
'
'-------------------------------------------------------------------
'
For FormulaColumnRow = 1 To UBound(FormulaColumnArray, 1) ' Loop through the FormulaColumnArray to check for '1's & '-1's
If FormulaColumnArray(FormulaColumnRow, 1) = "1" Or _
FormulaColumnArray(FormulaColumnRow, 1) = "-1" Then ' If a '1' or '-1' is found then ...
OutputArrayRow = OutputArrayRow + 1 ' Increment OutputArrayRow
'
If PreviousFormulaResultArray(FormulaColumnRow, 1) = 0 Then ' If previous value was '0' then ...
'
Application.Speech.Speak "At least one value in the," & _
"formula Column, was changed to, 1, or, -1.", SpeakAsync:=True ' Audible alert. Commas are a pause in speach ;)
'
OutputArray(OutputArrayRow) = "(" & _
FormulaColumnArray(FormulaColumnRow, 1) & _
") " & "Row # " & FormulaColumnRow + RowOffset ' Save the changed to value & row# into OutputArray
End If
End If
Next ' Loop Back
'
LastDestinationColumnNumber = wsDestination.Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column ' Get last Column Number used in the DestinationSheet
'
wsDestination.Cells(1, LastDestinationColumnNumber + 1) = Date ' Display the Date on DestinationSheet
wsDestination.Cells(2, LastDestinationColumnNumber + 1) = Time() ' Display the Time on DestinationSheet
wsDestination.Cells(3, LastDestinationColumnNumber + 1) = "------------------" ' Display spacer line on DestinationSheet
'
wsDestination.Cells(4, LastDestinationColumnNumber _
+ 1).Resize(UBound(OutputArray)) = _
Application.Transpose(OutputArray) ' Display results to DestinationSheet
'
'Save current formula results to the DestinationSheet
wsDestination.Range("A1") = Date ' Display the Date on DestinationSheet
wsDestination.Range("A2") = Time() ' Display the Time on DestinationSheet
wsDestination.Range("A3") = "------------------" ' Display spacer line on DestinationSheet
'
wsDestination.Range("A4").Resize(UBound(FormulaColumnArray)) = _
FormulaColumnArray ' Display results to DestinationSheet
'
wsDestination.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns
End If
'
'-------------------------------------------------------------------
'
SubExit:
End Sub
