I need help automatically changing cells containing a certain value whenever a specific cell on same row changes value.
E.g whenever a cell in B column changes = change TRUE to FALSE on that specific row.
My VBA knowledge is pretty much nonexistent and Im certainly a beginner.
Im fairly sure that Worksheet.Change is what Im looking for and I've been trying out some code I've found here on SO, such as:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Target.Parent.Range("B:B")) Is Nothing Then Exit Sub
For Each x In Target
Cells(x.Row, 3).Value = "False"
Next
End Sub
I know though that this doesn't replace specific values in whatever column the cells are.
I've been trying out silly things like:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Target.Parent.Range("B:B")) Is Nothing Then Exit Sub
For Each x In Target
If Cells(x.Row, x.Column).Value = "TRUE" Then Value = "FALSE"
Next
End Sub
But of course it doesnt work.
Think you could point me out a direction of what I should be researching?
Replace the change event sub on the sheet where you have your data with the code below. I think that should do the trick
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oRng As Range
Dim oCell As Range
' Check if change was in column B
If Intersect(Target, Target.Parent.Range("B:B")) Is Nothing Then Exit Sub
' Turn off events so that when we make a change on the sheet, this event is not triggered again
Application.EnableEvents = False
' Set the range to include all column in Target row
Set oRng = Target.Parent.Range("C" & Target.Row & ":" & Target.Parent.Cells(Target.Row, Target.Parent.UsedRange.Columns.Count).Address)
' Loop through all cells to change the value
For Each oCell In oRng
If Trim(LCase(oCell.Value)) = "true" Then
oCell.Value = "FALSE"
End If
Next
' Enable events again
Application.EnableEvents = True
End Sub
Related
I'm new to VBA so I'm probably making some beginner mistakes, please bare with me.
Here is the summary of my goal : I have several sheets in an Excel Workbook with the same structure. In each of those, I have a "Project Status" column with numbers ranging from 0 to 12. I'm trying to monitor a change in the column and, if the value of a cell changes, the row gets moved to the corresponding sheet and location.
My problem is that my code works but leaves an empty row where the row was cut. I tried adding
Target.EntireRow.Delete
but, if I add it before Insert the inserted row is empty, if I add it after it doesn't seem to do anything.
Here is a shorter version of my code, that I have in every sheet that is concerned by it :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.ScreenUpdating = False
If Target.Value = 0 Then
Target.EntireRow.Cut
IdeasUpcoming.Range("4:4").Insert
End If
If Target.Value = 1 Then
Target.EntireRow.Cut
IdeasUpcoming.Range("4:4").Insert
End If
If Target.Value = 2 Then
Target.EntireRow.Cut
Current.Range("STATUSNewProjects").Offset(1, 0).Insert
End If
If Target.Value = 3 Then
Target.EntireRow.Cut
Current.Range("STATUSAdvancedProjects").Offset(1, 0).Insert
End If
If Target.Value = 4 Then
Target.EntireRow.Cut
Completed.Range("STATUSFinished").Offset(1, 0).Insert
End If
If Target.Value = 5 Then
Target.EntireRow.Cut
Completed.Range("STATUSOld").Offset(1, 0).Insert
End If
End If
bm_Safe_Exit:
Application.ScreenUpdating = True
End Sub
How can I delete the row I'm cutting? I'm sure the If / End If for each cell value aren't optimal, is there a way to simplify this (considering this is shortened, in reality I have 13 values)?
Thank you a lot for your help.
You can use the range.copy logic like this - then you can delete the row afterwards:
With Target.EntireRow
.Copy IdeasUpcoming.cells(4,1)
.Delete xlShiftUp
End With
Regarding your multiple checks:
Maybe you can create a configuration array, which holds per index the target sheets range after that the row should be inserted
Dim arrTarget(1 to 15) as range
set arrTarget(1) = IdeasUpcoming.Cells(4,1)
...
set arrTarget(4) = Completed.Range("STATUSFinished")
Then you can use it like this - without Ifs:
'insert new row for row to be copied
arrTarget(Target.value).Offset(1).EntireRow.Insert xlShiftDown
With Target.EntireRow
.Copy arrTarget(Target.value).Offset(1)
.Delete xlShiftUp
End With
Furthermore you should have one generic copy routine in a normal module
Public sub moveRows(Target as range)
'define arrTarget
'do the copying
End sub
And then you call this generic routine from either all worksheet_change routines
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
moveRows target '-- this is where you call the generic sub
end if
End Sub
Or - if you have a sheetname logic to identify the relevant worksheets, e.g. data1, data2 etc. then you could use the workbook_SheetChange event (in the ThisWorkbook-module)
```vba
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name Like "data*" Then
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
moveRows Target '-- this is where you call the generic sub
End If
End If
End Sub
In case you have to make changes to your move-routine or the worksheet_change event, you only have to make changes in one place :-). (DRY: Don't repeat yourself)
I have a macro set up to perform a chunk of code in an 'onclick' event, and I'm trying to determine if they've selected a numeric value in a table range. An example of my table is below, and I'm trying to figure out if they've selected a number > 0 in the second column. I know how to reference the second column of a specific table, something like:
ListObjects("Table1").ListColumns(2).DataBodyRange
but I'm not sure how to figure out if the selected cell is in that range. Any suggestions? Thanks so much for your help!
Use Intersect.
Dim rangeToCheck as Range
Set rangeToCheck = Intersect(ActiveCell, ListObjects("Table1").ListColumns(2).DataBodyRange)
If Not rangeToCheck Is Nothing Then
If IsNumeric(ActiveCell.Value) Then
If ActiveCell.Value > 0 Then
' do the suff
End If
End If
End If
Assuming your table has filters then you have to check the visible cells only
Try this code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim r As Range
Set r = ListObjects(1).ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible)
Dim hit As Boolean
hit = Not Application.Intersect(r, Target) Is Nothing
If hit Then
Range("A1").Value = "Inside"
Else
Range("A1").Value = "Outside"
End If
Application.EnableEvents = True
End Sub
otherwise for all visible and non-visible cells use
Set r = ListObjects(1).DataBodyRange
I am using a VBA change event to look for duplicates in column C. The code below works but when i delete all values within the range, blanks are triggered as duplicates so i need to include a way to ignore duplicates from the code. Any ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
On Error GoTo ws_exit
Application.EnableEvents = False
With Target
If .Column = 3 Then
With .EntireColumn
Set cell = .Find(What:=Target.Value, AFter:=.Cells(1, 1))
If cell.Address = Target.Address Then
Set cell = .FindNext()
End If
If Not cell.Address = Target.Address Then
MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly
End If
End With
End If
End With
ws_exit:
Application.EnableEvents = True
End Sub
I expect to be able to ignore blanks but sill have the VBA run a duplication check to return a msgbox only if a duplication is found.
First you must consider that Target is a range of multiple cells and not only one cell. Therefore it is necessary to use Intersect to get all the cell that are changed in column 3 and then you need to loop through these cells to check each of them.
Also I recommend to use WorksheetFunction.CountIf to count how often this value occurs if it is >1 then it is a duplicate. This should be faster then using Find.
Note that the following code looks for duplicates in column 3 only if you want to check if a duplicate exists anywhere in the worksheet replace CountIf(Me.Columns(3), Cell.Value) with CountIf(Me.Cells, Cell.Value)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Columns(3))
If Not AffectedRange Is Nothing Then
Dim Cell As Range
For Each Cell In AffectedRange
If Application.WorksheetFunction.CountIf(Me.Columns(3), Cell.Value) > 1 Then
MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly + vbExclamation
End If
Next Cell
End If
End Sub
Instead of using VBA you could also use Conditional Formatting to highlight duplicates in red for example. Could be easier to archieve (use the =CountIf formula as condition). And also it will always highlight all duplicates immediately which makes it easy to determine them.
Thanks for the help K.Davis. I appreciate your time and effort.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = vbNullString Then Exit Sub
Dim cell As Range
On Error GoTo ws_exit
Application.EnableEvents = False
With Target
If .Column = 3 Then
With .EntireColumn
Set cell = .Find(What:=Target.Value, AFter:=.Cells(1, 1))
If cell.Address = Target.Address Then
Set cell = .FindNext()
End If
If Not cell.Address = Target.Address Then
MsgBox "This Glazing Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly
End If
End With
End If
End With
ws_exit:
Application.EnableEvents = True
End Sub
I'm creating a report-styled sheet in Excel, and trying to get a timestamp to automatically be entered in cell "P4" if cell "I6" has a value of "Completed"
I've tried using =IF formulas, which worked, but I'm unable to toggle iterative calculation on the machines this sheet will be working on.
I'm fairly new to writing my own VBA, and I'm having some trouble getting my current code to work. Below is what I currently have, which isn't giving me any results.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As String
Set r = Cells("I6")
If r.Value Is Nothing Then Exit Sub
If r.Value <> "Completed" Then Exit Sub
If r.Offset(-2, 7).Value <> "" Then Exit Sub
Application.EnableEvents = False
r.Offset(-2, 7) = Now()
Application.EnableEvents = True
End If
End Sub
I expect the code to give me a current timestamp in Cell "P4" once the value "Completed" is entered into cell "I6", but nothing is showing up. How would I correct it in order to get the value based timestamps?
As this sub is called at every cell's change (and you may use it later for other cell-checks also), check by Intersect first, if "your" cell is affected.
The changed range is given as Target (which may be a single cell or a complete range, e. g. when you paste on it). If that is intersected with your monitored cell I6, you can go ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RelevantArea As Range
Set RelevantArea = Intersect(Target, Me.Range("I6"))
If Not RelevantArea Is Nothing Then
If Target.Value = "Completed" Then
Application.EnableEvents = False
Me.Range("P4").Value = Now()
Application.EnableEvents = True
End If
End If
End Sub
I have a table of values that I need to fill out through a worksheet change function.
What I am trying to do is change a cell in columns B-G, depending on where the target is.
Private Sub Worksheet_Change(ByVal Target As Range)
If (Not Intersect(Target, Range(Cells(12, 2), Cells(14, 7))) Is Nothing) Then
Cells(16,Application.WorksheetFunction.Column(Target))="Hello"
End If
End Sub
I have similar bits of code in the same worksheet_change sub that work fine when I use Target.Offset(1,0) but since my possible target range is in more than 1 Row, I don't know how to make it so that it is always row 16 and the same column as the target....
You need to deal with situations where Target is more than a single cell and disable event handling so when you change a value on the worksheet, the Worksheet_Change doesn't try to run on top of itself.
This will put 'hello' into the cell immediately to the right of any cell within B:G that changes; essentially you would be adding 'hello' to columns C:H on the associated row of each cell in Target.
Private Sub Worksheet_Change(ByVal Target As Range)
if not intersect(target, Range(Cells(12, "B"), Cells(14, "G"))) is nothing then
on error goto safe_exit
application.enableevents = false
dim t as range
for each t in intersect(target, Range(Cells(12, "B"), Cells(14, "G")))
t.Offset(1,0) = "hello"
next t
End If
safe_exit:
application.enableevents = true
End Sub