VBA marking cells

CLE81

New Member
Joined
Oct 23, 2020
Messages
19
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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.

VBA Code:
------------------------------------------------------------------------------------------------------------------------------------

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
------------------------------------------------------------------------------------------------------------------------------------
 

Attachments

  • Capture.PNG
    Capture.PNG
    39.1 KB · Views: 3

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,872
Office Version
  1. 365
Platform
  1. Windows
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

New Member
Joined
Oct 23, 2020
Messages
19
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Mar 11, 2015
Messages
6,872
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Inserting, copying, deleting with a button is to difficult to explain/ learn collegues.
You have a very low opinion of your colleagues
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,872
Office Version
  1. 365
Platform
  1. Windows
Create a NEW workbook
Place code below in sheet1 code window
Try inserting and deleting rows

VBA Code:
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

Well-known Member
Joined
Mar 11, 2015
Messages
6,872
Office Version
  1. 365
Platform
  1. Windows
No longer watching this thread
 

CLE81

New Member
Joined
Oct 23, 2020
Messages
19
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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.

VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,118,210
Messages
5,570,918
Members
412,349
Latest member
big_words
Top