View Single Post
  #7   Report Post  
Posted to microsoft.public.excel.programming
Peter T Peter T is offline
external usenet poster
 
Posts: 5,600
Default Posting again. Please Help! How to "track changes" using VBA

to which methods are you referring to? [track changes]

By the way, have a look to the thread "Another change event request" (Jan
26th) if you have time, since we are posting about the same topic.

Paolo


I see in the other thread you want to trap changes on all sheets in all open
workbooks! Therefore I doubt you'll be interested in my "other methods",
unless each UsedRange is not too big.

FWIW as you asked, it means storing everything that you need to track, for
the period you need to track. What and for how long depends on needs. I did
say resources!

Eg:
-Want to track changes to existing number constants,
-Not interested in anything else, even newly added constants
-Want to replace or highlight changes at some point in the future,
-If cells have been "moved" (cut, dragged, inserted rows etc), ensure
replaced values go into correct cells.

Could store as arrays or into worksheets, advantages to each. Following is
into sheets in the code wb. Assumes code is in a dedicated workbook or
addin. All in a normal module although normally would be linked to events,
with variables passed around etc.

Put a mixture of stuff in active workbook. Run CopySheet. Change existing
constant values. Drag, cut, insert/delete rows, autofill, give it a hard
time. Run ChangedCells, try first time with bUndo = false.

'''''''''''''''''''''''''''''
Option Explicit
Dim wsSource As Worksheet
Dim wsVal As Worksheet 'copy of data from source sheet
Dim wsIf As Worksheet 'If formulas to compare changed cells

Sub CopySheet()
Dim rng As Range, ar As Range
Dim sF As String, sFa As String
' Ensure sheets 2 & 3 in ThisWorkbook are available
If ActiveWorkbook Is ThisWorkbook Then
MsgBox "In this demo ActiveWorkbook" & vbCr & _
"should not be ThisWorkbook"
Exit Sub
End If

Set wsSource = ActiveWorkbook.ActiveSheet
Set wsVal = ThisWorkbook.Worksheets(2)
Set wsIf = ThisWorkbook.Worksheets(3)


On Error Resume Next
'Due to 8000 areas limit of SpecialCells,
'might need to do in max chunks of 16000 cells.
'Error if no specialcells
Set rng = wsSource.Cells(1).SpecialCells(xlCellTypeConstants , 1)
On Error GoTo errH

wsVal.UsedRange.Clear
wsIf.UsedRange.Clear

If Not rng Is Nothing Then

'maybe trap/replace settings
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

sFa = "=If('[" & wsSource.Parent.Name & "]" & wsSource.Name & "'!"

For Each ar In rng.Areas
sF = sFa & ar(1).Address(0, 0) & "="
sF = sF & wsVal.Name & "!" & ar(1).Address(0, 0) & ","""",1)"

wsVal.Range(ar.Address) = ar.Value

With wsIf
.Range(ar(1).Address).Formula = sF
If ar.Rows.Count 1 Then
.Range(ar(1).Address).AutoFill .Range(ar.Address).Columns(1)
End If
If ar.Columns.Count 1 Then
.Range(ar.Address).Columns(1).AutoFill .Range(ar.Address)
End If
End With
Next
'perhaps a worksheet formula to count "If false" cells
End If

errH:
'don't need to restore app settings if "rng is Nothing"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub ChangedCells()
Dim bUndo As Boolean, bFill As Boolean
Dim vChanges
bUndo = True
bFill = True
vChanges = DoChanges(bUndo, bFill)
MsgBox "Changed cells: " & vChanges
End Sub

Function DoChanges(bRestore As Boolean, bHighlight As Boolean)
Dim rng As Range, cell As Range, sAddr As String, sF As String
Dim pos As Long, nLen As Long, nCx As Long

If wsIf Is Nothing Then
DoChanges = "Mod Sht variables Nothing"
Exit Function
End If

On Error Resume Next
Set rng = wsIf.Cells(1).SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo errH

If Not rng Is Nothing Then
nCx = IIf(bRestore And bHighlight, 15, 40)

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

For Each cell In rng
sF = cell.Formula
pos = InStr(cell.Formula, "!") + 1
nLen = InStr(pos, cell.Formula, "=") - pos
sAddr = Mid(cell.Formula, pos, nLen)

With wsSource.Range(sAddr)
If bHighlight Then
.Interior.ColorIndex = nCx
End If
If bRestore Then
.Value = wsVal.Range(cell.Address)
End If
End With
Next
DoChanges = rng.Count
Else: DoChanges = 0
End If
errH:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

If Err.Number Then
DoChanges = "Error #" & Err.Number
' Stop 'for debugging
' Resume
End If
End Function
''''''''''''''''''''''''

Values are not replaced in "removed" cells but a lot of info about these is
available in the "If" cells. SpecialCells error cells, #REF, etc. Could do
more in this respect.

Note - if any of the "If" cells change value a calculation event is
triggered in the parent workbook (might be useful where change events are
not triggered).

Not sure if it's viable to combine with a worksheet activate event, havn't
tried but maybe?

Briefly about events, I see a lot has been discussed in the "other thread"
but one more thing. As you know can trap "With Events" at application level,
workbook or sheet level. One advantage to either of the latter is can build
up an array or collection of "With Events", then variables can be assigned
uniquely to their respective class's (in same class module). Variables in
"others" are available if required with a prefixed reference.

Regards,
Peter T