VBA marking cells

[CLE81]

hi all,

I'm working on a Excel document with a list of items. Because many people are working with this document I need to register by whom, when and where (in the document) something is changed. All that is realized with VBA in Excel.

When someone changes a value in a cell the author name is written in a column, the date and time is written in a column and the cell that has changed gets a thick red border. After checking the changes by 2 persons (2 separate columns filling in "1"); the date, time and red border will be removed.

Till here everything is ok and working but when someone wants to insert a new row, delete a complete row or paste a complete row, via the right mouse click the entire line (till the end of the sheet and not only the written table) will be recognized as a change and will be marked like written above.

Is it possible to recognize wether some one is pastes, inserting or deleting a line? Is it possible to mark only changes in the area of the table?
Or has someone a better solution to realize the functionality as I want?

As attachement a capture of the table with an inserted line and the entire row marked.

Down below the used VBA-code.


br.

------------------------------------------------------------------------------------------------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
'--------------------------------------------------------------------------------------------------------------
' Registrate date, time and author of the change
'--------------------------------------------------------------------------------------------------------------
    Dim Bereik As Range, Controle As Range
    Dim DataNew

    Dim aw_name
    Dim sh_name
   
    Set Bereik = ActiveWorkbook.Sheets("Blad1").Range("C:F")
    Set Controle = Intersect(Target, Bereik)
   
    With ActiveWorkbook.Sheets(1)
                             
        If Not Controle Is Nothing Then
            'Write data
              .Range("A" & Target.Row) = DateValue(Now)
              .Range("B" & Target.Row) = TimeValue(Now)
              .Range("G" & Target.Row) = ThisWorkbook.BuiltinDocumentProperties("Last Author")
           
            'Markeer wijziging
             ' DataNew = Target.Value
             
             '  If DataOld <> DataNew Then
             If Target.Column >= 4 & Target.Column <= 7 Then
                    Target.Borders.LineStyle = xlContinuous
                    Target.Borders.Weight = xlThick
                    Target.Borders.Color = vbRed
              End If
              '      DataOld = Target.Value
              '  End If
           
                If Target.Cells.Count > 1 Then
                   Exit Sub
                End If
        End If
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'--------------------------------------------------------------------------------------------------------------
' Set selection rulers
'--------------------------------------------------------------------------------------------------------------
    [GesRij] = Target.Row
    [GesKol] = Target.Column
   
'--------------------------------------------------------------------------------------------------------------
' Calculate LastRow & LastColumn
'--------------------------------------------------------------------------------------------------------------
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim StartCell As Range
    Dim Check_01, Check_02
               
    aw_name = ActiveWorkbook.Name
       
    Set sh_name = Worksheets("Blad1")
    Set StartCell = Range("A2")
       
        'Find Last Row and Column
          LastRow = sh_name.Cells(sh_name.Rows.Count, StartCell.Column).End(xlUp).Row
          LastColumn = sh_name.Cells(StartCell.Row, sh_name.Columns.Count).End(xlToLeft).Column

'--------------------------------------------------------------------------------------------------------------
'Clear changes
'--------------------------------------------------------------------------------------------------------------
    sh_name = "Blad1"
                        
    With ActiveWorkbook.Sheets(sh_name)
   
          For i = 2 To LastRow

            Check_01 = Workbooks(aw_name).Sheets(sh_name).Cells(i, 8).Value
            Check_02 = Workbooks(aw_name).Sheets(sh_name).Cells(i, 9).Value
                              
            If (Check_01 = "1") And (Check_02 = "1") Then
                'Clear data
                .Range(Cells(i, 1), Cells(i, 2)).ClearContents
               
                'Clear marker
                .Range(Cells(i, 3), Cells(i, 6)).Borders.Color = vbBlack
                .Range(Cells(i, 3), Cells(i, 6)).Borders.LineStyle = xlContinuous
                .Range(Cells(i, 3), Cells(i, 6)).Borders.Weight = xlThin
               
                Workbooks(aw_name).Sheets(sh_name).Cells(i, 8).Value = ""
                Workbooks(aw_name).Sheets(sh_name).Cells(i, 9).Value = ""
            End If
        Next i
    End With
End Sub
------------------------------------------------------------------------------------------------------------------------------------

 

[CLE81]

nobody?

 

[Yongle]

There is noVBA event which detects row insert
But there are a few ways to"manufacture" an event

Is the sheet protected? Sheet protection allows you to prevent row insert. You can force a user to click on a button and log the change made

Another way is to name a cell BELOW anticipated used range (eg named range MyRange is A9999), then test to see if MyRange.Row = 9999 after every sheet calculation, and resetting that named range

 

[CLE81]

Protecting the sheet is not possible.
Inserting, copying, deleting with a button is to difficult to explain/ learn collegues.

Don't understand exactly what you mean with the last comment; the one with a cell BELOW

 

[Yongle]

Inserting, copying, deleting with a button is to difficult to explain/ learn collegues.

You have a very low opinion of your colleagues

 

[Yongle]

Create a NEW workbook
Place code below in sheet1 code window
Try inserting and deleting rows

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim msg$:   msg = "Inserted rows " & Target.Rows.Address(0, 0)
    On Error Resume Next
    Select Case Application.CommandBars("Standard").Controls("&Undo").List(1)
        Case "Insert Cells"
            MsgBox msg
        Case "Delete"
            MsgBox Replace(msg, "Inserted", "Deleted")
    End Select
    On Error GoTo 0
End Sub

After testing incorporate the same method into your original macro

 

[Yongle]

No longer watching this thread

 

[CLE81]

I fixed the problem using another piece of code.

I placed an if statement checking the column amount in the target. This variable seems to be "1"when cutting/ inserting/ paste rows. When the column value is "1" the sub will be exit.

Sub ChangeNote(Target)
'--------------------------------------------------------------------------------------------------------------
' Registrate date, time and author of the change
'--------------------------------------------------------------------------------------------------------------
    Dim Bereik As Range, Controle As Range
    Dim DataNew
 
    Dim aw_name
    Dim sh_name
    
    Set Bereik = ActiveWorkbook.Sheets("Blad1").Range("C:F")
    Set Controle = Intersect(Target, Bereik)
    
    With ActiveWorkbook.Sheets(1)

            If Not Controle Is Nothing Then
                        'Insert/ Delete/ Cut gives column value "1", no marking needed
                        If Target.Cells.Column = 1 Then
                           Exit Sub
                        End If

                        'Write data
                          .Range("A" & Target.Row) = DateValue(Now)
                          .Range("B" & Target.Row) = TimeValue(Now)
                          .Range("G" & Target.Row) = ThisWorkbook.BuiltinDocumentProperties("Last Author")
                        
                        'Mark Change
                          Target.Borders.LineStyle = xlContinuous
                          Target.Borders.Weight = xlThick
                          Target.Borders.Color = vbRed
                                                 
                          If Target.Cells.Count > 1 Then
                                Exit Sub
                         End If
            End If
    End With
End Sub