Adding a note to a cell based on another cell - excel

I am trying to add a specific note to a cell based on the cell value to explain what the cell contents are. I am trying to use the code below to do this but I get a run-time error '1004' on the following line:
Target.Cells.Comment.Text Text:=Comment_E
Private Sub Worksheet_Change(ByVal Target As Range)
'Defining what column is being changed
If Target.Column = 3 Then
'Adding a comment to the cell
Dim Status_Col As String
Dim NA As String
Dim i As Integer
'Types
Dim Comment_T As String
'Explainations
Dim Comment_E As String
i = 4
Comment_T = Target.Cells.Value
For i = 4 To 10 ' checking the list of types
If Cells(i, 14).Value = Comment_T Then
Comment_E = Cells(i, 15).Value
End If
Next i
Target.Cells.Select
Target.Cells.AddComment
Target.Cells.Comment.Visible = False
Target.Cells.Comment.Text Text:=Comment_E
Selection.ShapeRange.ScaleHeight 0.48, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 3.32, msoFalse, msoScaleFromTopLeft
End If
End Sub

You need to account for the case where a cell already has a comment, and the case where multiple cells are updated (eg fill down).
Few fixes/suggestions:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v, cmt As Comment, rng As Range, c As Range
'any changes in Col3?
Set rng = Application.Intersect(Target, Me.Columns(3))
'optionally set some limit for the size of change you want to handle
If rng.Cells.CountLarge > 100 Then Exit Sub
'now process each cell in the col3 range
For Each c In rng.Cells
v = Application.VLookup(c.Value, Me.Range("N4:O10"), 2, False)
If Not IsError(v) Then
Set cmt = c.Comment 'already has a comment?
If cmt Is Nothing Then
Set cmt = c.AddComment() 'no comment so add one
With cmt 'formatting...
.Visible = False
.Shape.Height = 30 'fixed height/width is easier
.Shape.Width = 100
End With
End If
cmt.Text v 'set/replace text
End If
Next c
End Sub

Related

Private sub update date automatically when value in a cell changes

Im trying to automatically update current date in cell T when text in cell Q is "won" and a value in cell AM is > 0. I tried the code below and it is working if first the value in cell is > 0 and then you update the text in cell Q BUT if you do it in another way (first update cell Q and secondly the value in cell AM) the date doesn't appear in cell T.
Any idea, what Im I missing?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [Q:Q]) Is Nothing Then
If UCase(Target) = UCase("won") And Target.Offset(, 22) > 0 Then
Target.Offset(, 2) = Int(Now())
End If
End If
End sub
Your code only checks for changes in Q therefore the update does not take place if you change AM first.
My solution has three parts:
use constants for the columns - in case there are changes to the sheet layout you only have to make adjustments here
worksheet_change: only check if one of the columns is affected then call the according sub - by that the reader of the code immediately understands what is going on here
the main routine that inserts the date if condition is met or removes the date if not (maybe you want to adjust this)
Option explicit
Private Const colStatus As String = "Q"
Private Const colValue As String = "AM"
Private Const colDateWon As String = "S"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Set c = Target.Cells(1, 1)
If c.Column = Me.Columns(colStatus).Column Or c.Column = Me.Columns(colValue).Column Then
updateDateWon c.row
End If
End Sub
Private Sub updateDateWon(row As Long)
'--> adjust the name of the sub to your needs
Dim valueToInsert As Variant
With Me
If .Range(colStatus & row) = "won" And .Range(colValue & row) > 0 Then
valueToInsert = Int(Now)
Else
'reset the date in case conditions are not met
valueToInsert = vbNullString
End If
Application.EnableEvents = False 'disable events so that change-event isn't called twice
.Range(colDateWon & row) = valueToInsert
Application.EnableEvents = True
End With
End Sub
A Worksheet Change Applied to Two Non-Adjacent Columns
You need to monitor columns Q and AM for changes.
You need to account for Target being multiple adjacent and non-adjacent cells.
You need to disable events when writing to the worksheet containing this code to not retrigger this event (or trigger any other events).
It is good practice to ensure the re-enabling of events (by using error-handling).
You can combine the cells to be written to (dCell) into a range (drg) and write the stamp in one go.
Int(Now()) or Int(Now) is actually Date.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Const sColsAddress As String = "Q:Q,AM:AM"
Const dCol As String = "T"
Const fRow As Long = 2 ' (e.g. 2 for excluding headers in the first row)
Const sCriteria As String = "won"
Dim srg As Range
With Range(sColsAddress)
Set srg = Intersect(.Cells, Rows(fRow).Resize(Rows.Count - fRow + 1))
End With
Dim sirg As Range: Set sirg = Intersect(srg, Target)
If sirg Is Nothing Then Exit Sub
Dim sirg1 As Range: Set sirg1 = Intersect(sirg.EntireRow, srg.Areas(1))
Dim siCol2 As Long: siCol2 = srg.Areas(2).Column
'Dim dirg As Range: Set dirg = sirg1.EntireRow.Columns(dCol) ' not used
Dim siCell1 As Range
Dim siValue2 As Variant
Dim drg As Range
For Each siCell1 In sirg1.Cells
If StrComp(CStr(siCell1.Value), sCriteria, vbTextCompare) = 0 Then
siValue2 = siCell1.EntireRow.Columns(siCol2).Value
If IsNumeric(siValue2) Then
If siValue2 > 0 Then
If drg Is Nothing Then
Set drg = siCell1.EntireRow.Columns(dCol)
Else
Set drg = Union(drg, siCell1.EntireRow.Columns(dCol))
End If
End If
End If
End If
Next siCell1
If Not drg Is Nothing Then
' Prevent retriggering the event when writing to the worksheet.
Application.EnableEvents = False
drg.Value = Now ' only after testing, use 'dDate = Date'
End If
SafeExit:
' Enable events 'at all cost'.
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub

Conflict between two events if Filtermode = False and any cells changed by Fill handle. Error raised (Method 'Undo' of object 'Application' failed)?

I have two codes depend on application events to run.
Code (1) change color of column_A If FilterMode is True on any column of ActiveSheet.
Code (2) Log changes of any cells in ActiveSheet and put in another sheet("Log").
Error raised if : Filtermode = False and any cells changed by fill handle (the small square in the lower-right corner of the selected cell) ,
I got this error
Method 'Undo' of object '_Application' failed
on this line Application.Undo on Code (2).
I tried to use to disable and enable events with code (1) with no luck.
any help will be appreciated.
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
'Code (1) change color of column_A If FilterMode is True on any column of active sheet.
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(196, 240, 255)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End Sub
' Code (2) Log Changes of Current Sheet and put in Sheet("Log")
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
Dim sh As Worksheet: Set sh = Sheets("Log")
Dim UN As String: UN = Environ$("username")
If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in "AK:XFD" is changed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'Avoide trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'Define RangeValue
putDataBack TgValue, ActiveSheet 'Reinsert changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
'Array("User Name", "Date,Time", "Work Order", "Column Label", "New Value", "Old Value")
Range(RangeValues(r)(1)).EntireRow.AutoFit
If Range(RangeValues(r)(1)).RowHeight < 53 Then
Range(RangeValues(r)(1)).RowHeight = 53
End If
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.Cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.Cells.count
arr(count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I figured out the issue, although the error rising with code (2) Worksheet_Change event ,
But actually SelectionChange event on code(1) is the real problem.
Apparently, when I drag down, it is sort of like selecting cells individually and all of them at the same time.
To solve this issue, a condition must be added to event SelectionChange to count the target cells:
If Target.Cells.CountLarge = 1 then
So I just modified the code to look like this in the SelectionChange part and it now works perfectly.
'Code (1)
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Cells.CountLarge = 1 Then
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(255, 0, 0)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End If
End Sub
In the meantime, I learned that Calculate event would be best choice to trapping a change to a filtered list as described on this link
https://www.experts-exchange.com/articles/2773/Trapping-a-change-to-a-filtered-list-with-VBA.html

How to change cell value based on input number

I want to fill the cells with Character Abbreviation, according to the entering number in that cell.
For example I created the following image Where the Column L should be filled with DM, AG, IW, WSW, CW. For this purpose, I used numeric values from 1 to 5 (DM=1, AG=2, IW=3, WSW=4, CW=5). I already
For this, I already entered those values (AR6:AW17) as following in the same sheet.
Tried
I used the following code :
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("L:L")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim foundVal As Range
Set foundVal = Range("AR5:AV5").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(1, 0)
End If
Application.ScreenUpdating = True
End Sub
Problem
My question is how can I extend this to put the values to
Column L as AR6:AV6
Column M as AR7:AW7
Column P as AR8:AV8
Column Q as AR14:AU14
Column T as AR15:AV15
Column W as AR17:AU17
Updated
The column Q, T, W are added for more consideration please.
and so on, please?
Resize and Offset in Worksheet Change
Adjust the values in the constants section.
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ColRangesList As String = "L,M,N,P"
Const RowRangesList As String = "AR5:AV5,AR6:AW6,AR7:AS7;AT8:AX8"
Const RowOffset As Long = 1
Const ColOffset As Long = 0
If Target.Cells.CountLarge = 1 Then
Dim ColRanges() As String: ColRanges = Split(ColRangesList, ",")
Dim RowRanges() As String: RowRanges = Split(RowRangesList, ",")
Dim crg As Range, rrg As Range, cel As Range
Dim n As Long
For n = 0 To UBound(ColRanges)
Set crg = Columns(ColRanges(n))
Set rrg = Range(RowRanges(n))
If Not Intersect(Target, crg) Is Nothing Then
Set cel = rrg.Find(Target.Value, rrg.Cells(rrg.Cells.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole)
If Not cel Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Target.Value = cel.Offset(RowOffset, ColOffset).Value
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit For
End If
End If
Next n
End If
End Sub

Using target offset to clear a range of cells in excel

I'm trying to clear a range of 5 cells when changing another. For example: H5 is changed, J5:J10 is cleared. This works a treat in clearing J5 when H5 is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Left(Target.Address(, False), 1) = "H" Then Target.Offset(, 2).ClearContents
End Sub
However this does not clear the 4 cells below. I was wary of using a function to specify the range as I've got multiple rows of data in H. So for example if H24 changes, J24:J29 are cleared, which goes on for about 200 rows...
Any help is appreciated!
The Offset-function returns a range with the same size than the original Range, just at a different place. To increase (or decrease) the size of a range, you can use the Resize-function. So basically, you need to combine both functions.
I don't want to argue with you about how to check for the column, but I think using If Target.Column = 8 Then is much easier.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then ' Col H
Dim destRange As Range
Set destRange = Target.Offset(0, 2).Resize(5, 1)
Debug.Print destRange.Address
destRange.ClearContents
End If
End Sub
Be aware that Target may contain more than one cell (eg via Cut&Paste), you probably need to handle that.
This should do it.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
Application.EnableEvents = True
End Sub
Okay with merged cells offset gets weird and even offsetting the topleft cell of the merged area (Target.MergeArea(1, 1)) will give bad results so we need to create the range ourselves.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.MergeCells = True Then
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(0, 2), ActiveSheet.Cells(Target.MergeArea(1, 1).Row + 5, Target.MergeArea(1, 1).Offset(0, 2).Column)).ClearContents
Else
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
End If
Application.EnableEvents = True
End Sub
I hardcoded the 5 into the row change if you need it to be the size of the merged area you will need to get the difference in rows from the top to the bottom of the merged area.
Clear Cells on Any Side of Merged Cells
The colors in the image show which contents will be cleared in column J if a value in a cell in column H is changed (manually or via VBA).
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim doEnableEvents As Boolean
On Error GoTo clearError
Const FirstCellAddress As String = "H2"
Const ColOffset As Long = 2
Dim irg As Range
With Range(FirstCellAddress)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If Not irg Is Nothing Then
Application.EnableEvents = False
doEnableEvents = True
Dim arg As Range
Dim cel As Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If cel.MergeCells Then
With cel.MergeArea
.Cells(1, 1).Offset(, ColOffset).Resize(.Rows.Count) _
.ClearContents
End With
Else
cel.Offset(, ColOffset).ClearContents
End If
Next cel
Next arg
End If
ProcExit:
If doEnableEvents Then
Application.EnableEvents = True
End If
Exit Sub
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Sub testMultiArea()
Dim rg As Range: Set rg = Range("H2,H7")
rg.Value = 500
End Sub

worksheet change event only works when region selected - how to adjust to automatic update

the combination of this sub in a module
Sub hithere3()
Dim Rng As Range
Dim Unique As Boolean
For Each Rng In Worksheets("Sheet8").Range("FS3:FS30") 'for each cell in your B1 to B30 range, sheet1
Unique = True 'we'll assume it's unique
Lastunique = Worksheets("TRADES").Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 3 To Lastunique 'for each cell in the unique ID cache
If Rng.Value = Worksheets("TRADES").Cells(i, 3).Value Then 'we check if it is equal
Unique = False 'if yes, it is not unique
End If
Next
If Unique Then Worksheets("TRADES").Cells(Lastunique + 1, 3) = Rng 'adds if it is unique
Next
End Sub
with the loop check in a worksheet change events
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
works except it only updates when I select one of the cells in FS3:FS33
Can anyone suggest how this can be overcome?
maybe with a workchange change range selection type from below?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim RngB As Range, RngC As Range
If Target.Column = 2 And Target.Count = 1 And Target.Row > 1 Then
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Set RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
Set RngC = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
ray = Array(RngB, RngC)
For n = 0 To 1
For Each Dn In ray(n)
If Not Dn.Address(0, 0) = "C1" And Not Dn.Value = "" Then
.Item(Dn.Value) = Empty
End If
Next Dn
Next n
Range("C2").Resize(.Count) = Application.Transpose(.Keys)
End With
End If
Use either the worksheet Calculate event or the worksheet Change event:
use Calculate if the range contains formulas
use Change if the cells in the range are changed manually
If Intersect(Target, Range("FS3:FS33")) Is Nothing is the culprit. You must change Range("FS3:FS33") to whatever range you want to affect this change.
Private Sub Worksheet_Change(ByVal Target As Range) '<<delete the "Selection" from the name of event
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
Finally figured it out, the following code works :
Private Sub Worksheet_calculate()
If Range("FS3:FS33") Is Nothing Then
'Do nothing'
Else
Call hithere3
End If
End Sub

Resources