Here is my code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim ws As Worksheet
For Each c In Intersect(Target, Range("F9:N46"))
If c.Comment Is Nothing And c.Value <> "" Then
With c.AddComment
.Visible = False
.Text Application.UserName & ":" & Date & " - " & c.Value
End With
ElseIf Not c.Comment Is Nothing And c.Value <> "" Then
c.Comment.Text Application.UserName & ":" & Date & " - " & c.Value & vbNewLine & c.Comment.Text
End If
Next
End Sub
The problem is that if I edit a cell that is not in my defined range I get an error like this:
How can I make this work for cell F9:N46 only?
I solved it by adding an If statement as shown below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim ws As Worksheet
If Not Intersect(Target, Range("F9:N46")) Is Nothing Then
For Each c In Target
If c.Comment Is Nothing And c.Value <> "" Then
With c.AddComment
.Visible = False
.Text Application.UserName & ":" & Date & " - " & c.Value
End With
ElseIf Not c.Comment Is Nothing And c.Value <> "" Then
c.Comment.Text Application.UserName & ":" & Date & " - " & c.Value & vbNewLine & c.Comment.Text
End If
Next
End If
End Sub
Related
I am using the following in a macro to add a comment when a cell value is changed:
Private Sub Worksheet_Change(ByVal Target As Range)
Const xRg As String = "C4:AK100"
Dim strOld As String
Dim strNew As String
Dim strCmt As String
Dim strCmt2 As String
Dim Cell As Range
Dim rngComm As Range
Dim ws As Worksheet`your text`
Dim c As Range
Dim Comment As CommentThreaded
With Target(1)
If Intersect(.Cells, Range(xRg)) Is Nothing Then Exit Sub
strNew = .Text
Application.EnableEvents = False
Application.Undo
strOld = .Text
.Value = strNew
Application.EnableEvents = True
strCmt = "Uppdated: " & Format$(Now, "YYYY/ MM/ DD ") & Chr(10) & "By: " & _
Application.UserName & Chr(10) & "Before update : " & strOld
If Target(1).CommentThreaded Is Nothing Then
.AddCommentThreaded (strCmt)
ActiveCell.CommentThreaded.Resolved = True
strCmt2 = "Updated: " & Format$(Now, "YYYY/ MM/ DD ") & Chr(10) & "By: " & _
Application.UserName & Chr(10)
Range("AM3").Value = strCmt2
Range("AM2").Value = Now
Range("AM2").NumberFormat = "YYYY-MM-DD"
Else
ActiveCell.ClearComments
strCmt = "Updated: " & Format$(Now, "YYYY/ MM/ DD ") & Chr(10) & "By: " & _
Application.UserName & Chr(10) & "Before update : " & strOld
If Target(1).CommentThreaded Is Nothing Then
.AddCommentThreaded (strCmt)
ActiveCell.CommentThreaded.Resolved = True
Range("AM3").Value = strCmt2
Range("AM2").Value = Now
Range("AM2").NumberFormat = "YYYY-MM-DD"
End If
End If
End With
End Sub
I would like to add a function so when the macro is triggered get and output the information of the first cell in the same row and column ("Name" and "Place") in a separate cell ("AM2")
I used to google, read forums but didn't find any solution
Sorry for the confusion but what i ment is Column B starting from cell B4 and downwards contains names and row 3 starting at C3 contain city names, what I would like is to display the name and the city in cell AN2 when I change a value in any cell in range C4:AK100 .
worksheet
I have written the below code in excel vba to log changes made in sheets to the change log sheet. I want to disable that sub if a check box is checked.
This code works perfectly for what I need it to do, just need to figure out a sub that does not allow this to run if a box is checked so every change is not being logged when necessary.
'declare global variable
Dim oldValue As String
Dim oldAddress As String
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'declare variables for individual sheets
Dim sheet1 As String
NSWCCDFY22M = "Sheet 1"
Dim sheet2 As String
NSWCCDFY23M = "Sheet 2"
Dim sheet3As String
NSWCCDLSW = "Sheet 3"
'Logs change for any sheet that isnt the log itself (address, values, user, date/time, hyperlink, note)
If ActiveSheet.Name <> "ChangeLog" Then
Application.EnableEvents = False
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " – " & Target.Address(0, 0)
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = oldValue
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
'hyperlink to specific sheet
If ActiveSheet.Name = Sheet 1 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 1 & "'!" & oldAddress, TextToDisplay:=oldAddress
ElseIf ActiveSheet.Name = Sheet 2 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 2 & "'!" & oldAddress, TextToDisplay:=oldAddress
ElseIf ActiveSheet.Name = Sheet 3 Then
Sheets("ChangeLog").Hyperlinks.Add Anchor:=Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", SubAddress:="'" & Sheet 3 & "'!" & oldAddress, TextToDisplay:=oldAddress
End If
'input box for note
Dim commentChange As String
commentChange = InputBox("Please enter a note for this change.", "Logging")
Sheets("ChangeLog").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = commentChange
'if input box is not filled in
If LenB(commentChange) = 0 Then
MsgBox "You must enter a note for the change you've just made." & vbCrLf & " " & vbCrLf & "You will be taken to the Change Log to add a note and can navigate back to this sheet using the link associated with your change.", vbExclamation, "Change Log Required Actions"
Sheets("ChangeLog").Select
'go to log if a note is not put in
Dim lRow As Long
Dim lColumn As Long
lRow = Range("A1").End(xlDown).Row
lColumn = Range("A1").End(xlToRight).Column
Cells(lRow, lColumn).Select
Dim OutPut As Integer
'infobox when taken to log
OutPut = MsgBox("1. Please enter a note for the change you've just made." & vbCrLf & " " & vbCrLf & "2. Click the link in the 'Link' Column to return to the previous sheet where the change was made.", vbInformation, "Change Log Required Actions")
End If
Sheets("ChangeLog").Columns("A:G").AutoFit
Application.EnableEvents = True
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Count = 1 Then
oldValue = Target.Value
End If
oldAddress = Target.Address
End Sub
I have code to check empty cells in a range. I need those empty cell numbers to appear in a MsgBox.
Sub IsEmptyRange()
Dim cell As Range
Dim bIsEmpty As Boolean
bIsEmpty = False
For Each cell In Range("B1:B19")
If IsEmpty(cell) = True Then
bIsEmpty = True
Exit For
End If
Next cell
If bIsEmpty = True Then
MsgBox "There are empty cells in your range"
'I NEED THE EMPTY CELLS TO APPEAR IN THE ABOVE MSGBOX
End If
End Sub
Just use:
msgbox Range("B1:B19").SpecialCells(xlCellTypeBlanks).Address
This solution adapts your code.
Dim cell As Range
Dim emptyStr As String
emptyStr = ""
For Each cell In Range("B1:B19")
If IsEmpty(cell) Then _
emptyStr = emptyStr & cell.Address(0, 0) & ", "
Next cell
If emptyStr <> "" Then MsgBox Left(emptyStr, Len(emptyStr) - 2)
If the cell is empty, it stores the address in emptyStr. The if condition can be condensed as isEmpty returns a Boolean.
Please try this code.
Sub ListEmptyCells()
Dim Rng As Range
Dim List As Variant
Dim Txt As String
Set Rng = Range("B1:B19")
On Error Resume Next
List = Rng.SpecialCells(xlCellTypeBlanks).Address(0, 0)
If Err Then
Txt = "There are no empty cells in" & vbCr & _
"the examined range."
Else
Txt = "The following cells are empty." & vbCr & _
Join(Split(List, ","), vbCr)
End If
MsgBox Txt, vbInformation, "Range " & Rng.Address(0, 0)
Err.Clear
End Sub
It uses Excel's own SpecialCells(xlCellTypeBlank), avoiding an error which must occur if this method returns nothing, and presenting the result in a legible format created by manipulating the range address if one is returned.
List blanks via dynamic arrays and spill range reference
Using the new dynamic array possibilities of Microsoft 365 (writing e.g. to target C1:C? in section b))
=$B$1:$B$19=""
and a so called ►spill range reference (as argument in the function Textjoin(), vers. 2019+ in section c))
C1# ' note the `#` suffix!
you could code as follows:
Sub TestSpillRange()
With Sheet1
'a) define range
Dim rng As Range
Set rng = .Range("B1:B19")
'b) check empty cell condition and enter boolean values into spill range C1#
.Range("C1").Formula2 = "=" & rng.Address & "="""""
'c) choose wanted values in spill range and connect them to result string
Dim msg As Variant
msg = Evaluate("TextJoin("","",true,if(C1#=true,""B""&row(C1#),""""))")
MsgBox msg, vbInformation, "Empty cells"
End With
End Sub
Find Blank Cells Using 'SpecialCells'
The 2nd Sub (listBlanks) is the main Sub.
The 1st Sub shows how to use the main Sub.
The 3rd Sub shows how SpecialCells works, which on one hand might be considered
unreliable or on the other hand could be used to one's advantage.
After using the 3rd Sub, one could conclude that SpecialCells 'considers' only cells at the intersection of the UsedRange and the 'supplied' range.
The Code
Option Explicit
Sub testListBlanks()
Const RangeAddress As String = "B1:B19"
Dim rng As Range: Set rng = Range(RangeAddress)
listBlanks rng
listBlanks rng, True
End Sub
Sub listBlanks(SourceRange As Range, _
Optional useList As Boolean = False)
Const proc As String = "'listBlanks'"
On Error GoTo clearError
Dim rng As Range: Set rng = SourceRange.SpecialCells(xlCellTypeBlanks)
Dim msgString As String
GoSub writeMsg
MsgBox msgString, vbInformation, "Blank Cells Found ('" & proc & "')"
Exit Sub
writeMsg:
msgString = "Blank Cells in Range '" & SourceRange.Address(False, False) _
& "'" & vbLf & vbLf & "The cells in range '" _
& rng.Address(False, False) & "' are blank."
If useList Then GoSub writeList
Return
writeList:
Dim cel As Range, i As Long, CellList As String
For Each cel In rng.Cells
CellList = CellList & vbLf & cel.Address(False, False)
Next cel
msgString = msgString & vbLf & vbLf _
& "The range contains the following " & rng.Cells.Count _
& " empty cells:" & vbLf & CellList
Return
clearError:
If Err.Number = 1004 And Err.Description = "No cells were found." Then
MsgBox "No blank cells in range '" & SourceRange.Address(False, False) _
& "' were found.", vbInformation, "No Blanks ('" & proc & "')"
Exit Sub
Else
MsgBox "An unexpected error occurred." & vbLf _
& "Run-time error '" & Err.Number & "': " & Err.Description, _
vbCritical, "Error in " & proc
End If
End Sub
Sub testUsedRangeAndSpecialCells()
Const wsName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
With ws
.Range("A:B").ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(1, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 1).Value = 1
Debug.Print .UsedRange.Address
.Cells(2, 2).Value = 2
Debug.Print .UsedRange.Address
.Cells(2, 3).Value = 3
Debug.Print .UsedRange.Address
.Cells(2, 3).ClearContents
Debug.Print .UsedRange.Address
.Cells(1, 2).ClearContents
Debug.Print .Columns("B").SpecialCells(xlCellTypeBlanks).Address
Dim rng As Range: Set rng = .Columns("C")
Debug.Print rng.Address
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
If Err.Number <> 0 Then
MsgBox "We know that all cells are blank in range '" _
& rng.Address(False, False) & "', but 'SpecialCells' " _
& "doesn't consider them since they are not part of 'UsedRange'."
Debug.Print "No blank cells (not quite)"
Else
Debug.Print rng.Address
End If
On Error Goto 0
.Cells(3, 4).Value = 4
Set rng = rng.SpecialCells(xlCellTypeBlanks)
Debug.Print rng.Address(False, False)
End With
End Sub
The result of the 3rd Sub (testUsedRangeAndSpecialCells)
$A$1
$A$1
$A$1:$B$1
$A$1:$B$2
$A$1:$B$2
$A$1:$C$2
$A$1:$B$2
$B$1
$C:$C
No blank cells (not quite)
C1:C3
I am looking for a function to print in a comment box, who was the users that changed the data from that cell. What I have for now is this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
On Error GoTo EndeSub
Application.EnableEvents = False
Range("B" & Target.Row) = Now
End If
EndeSub:
Application.EnableEvents = True
End Sub
It "triggers" automatically when someone types something in a cell.
And is printing only the last user name that changed the data, but I want to be some kind of a log, to print all the users. Do you think it is possible?
One way is, insert a New Sheet and name it "Log" and place the two headers like this...
On Log Sheet
A1 --> Date/Time
B1 --> User
Now replace your existing code with this...
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
Dim wsLog As Worksheet
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
On Error GoTo EndeSub
Set wsLog = Sheets("Log")
Application.EnableEvents = False
Range("B" & Target.Row) = Now
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 1) = Environ("UserName")
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1) = Now
End If
EndeSub:
Application.EnableEvents = True
End Sub
So each time any user makes changes in the target range, the time of change and the user name will be listed on Log Sheet.
Edit:
As per the new setup, these column headers should be there on the Log Sheet.
A1 --> Date/Time
B1 --> User
C1 --> Cell
D1 --> Old Value
E1 --> New Value
Then replace the existing code with the following two codes...
Dim oVal
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
Dim wsLog As Worksheet
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
On Error GoTo EndeSub
Set wsLog = Sheets("Log")
Application.EnableEvents = False
Range("B" & Target.Row) = Now
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 1) = Environ("UserName")
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 2) = Target.Address(0, 0)
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 3) = oVal
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 4) = Target.Value
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1) = Now
End If
EndeSub:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
oVal = Target
End If
End Sub
In a Public Module
Sub LogChange(Target As Range)
Dim cell As Range, vNew As Variant, vOld As Variant
vNew = Target.value
Application.Undo
vOld = Target.value
Target.value = vNew
With getLogWorksheet
With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
' Array("Date/Time", "UserName", "Worksheet", "Address", "Old Value", "New Value")
.Resize(1, 6).value = Array(Now, Environ("UserName"), Target.Parent.Name, Target.Address(False, False), vOld, vNew)
End With
End With
End Sub
Private Function getLogWorksheet() As Workbook
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Log")
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Visible = xlSheetVeryHidden
ws.Name = "Log"
ws.Range("A1").Resize(1, 6).value = Array("Date/Time", "UserName", "Worksheet", "Address", "Old Value", "New Value")
End If
End Function
In a Worksheet Module
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then
Application.Undo
MsgBox "Changing more than 1 cell at a time is prohibited", vbCritical, "Action Undone"
ElseIf Not Intersect(Range("C:JA"), Target) Is Nothing Then
LogChange Target
End If
End Sub
Another bit of code to give you some ideas:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
val_before = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then
MsgBox Target.Count & " cells were changed!"
Exit Sub
End If
If Target.Comment Is Nothing Then
Target.AddComment
existingcomment = ""
Else
existingcomment = Target.Comment.Text & vbLf & vbLf
End If
Target.Comment.Text Text:=Format(Now(), "yyyy-mm-dd") & ":" & vbLf & Environ$("Username") & _
" changed " & Target.Address & " from:" & vbLf & """" & val_before & _
"""" & vbLf & "to:" & vblkf & """" & Target.Value & """"
End Sub
Any time a cell is selected, it stores the cell's existing value in a variable. If the cell is changed, it creates a new comment in the cell (or appends the existing comment if there is one) with the date, username, cell address, and the "before and after" values. This could be super annoying if someone's trying to make a lot of changes, and if there are multiple changes at once, then it will just warn you without creating a comment. I'd suggest you practice on a blank workbook (or a 2nd copy of the one you're working on) in case there are any problems. Be sure to Google any of the properties/methods than you are unfamiliar with, for the sake of learning, and for building a solution to fit your needs!
I search before in this site, but not really found same case with my code. Hope someone here can help me on this.
How to combine two Private sub below?
1st code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("P:P")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
Dim NR As Long
With Application
.EnableEvents = False
.ScreenUpdating = False
Select Case Target.Value
Case "CLOSED"
NR = Worksheets("Closed").Range("D1500").End(xlUp).Offset(1).Row
Range("B" & Target.Row & ":P" & Target.Row).Copy Worksheets("Closed").Range("B" & NR)
Rows(Target.Row).Delete
Case "Re-handover"
NR = Worksheets("Handover").Range("D1500").End(xlUp).Offset(1).Row
Range("E" & Target.Row & ":O" & Target.Row).Copy Worksheets("Handover").Range("E" & NR)
' Rows(Target.Row).Delete
End Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
2nd code
Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 15 Then Exit Sub
Target.ClearComments
Target.AddComment.Text Text:="Updated " & Format(Date, "dd mmm yyyy") & " " & Format(Time, "hh:mm") & Chr(10) & "By " & Environ("UserName")
End Sub
thank you very much before
Would this work?
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
*If target.column=15 then
Target.ClearComments
Target.AddComment.Text Text:="Updated " & Format(Date, "dd mmm yyyy") & " " & Format(Time, "hh:mm") & Chr(10) & "By " & Environ("UserName")
else
endif *
If Intersect(Target, Range("P:P")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Dim NR As Long
With Application
.EnableEvents = False
.ScreenUpdating = False
Select Case Target.Value
Case "CLOSED"
NR = Worksheets("Closed").Range("D1500").End(xlUp).Offset(1).Row
Range("B" & Target.Row & ":P" & Target.Row).Copy Worksheets("Closed").Range("B" & NR)
Rows(Target.Row).Delete
Case "Re-handover"
NR = Worksheets("Handover").Range("D1500").End(xlUp).Offset(1).Row
Range("E" & Target.Row & ":O" & Target.Row).Copy Worksheets("Handover").Range("E" & NR)
' Rows(Target.Row).Delete
End Select
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub