Clear contents of cells when the cell left of it changes - vba

I'm trying to get a piece of code that, when a cell in column 8 changes it deletes the value of cell next to it(column 9).
Well... That is the simple version
Column 8 and 9 are both dropdown lists, the dropdown list in column 9 is dependent on column 8. In column 9, multiple answers are necesary so i found a code on the internet that made that possible, but now the value in column 9 doesn't delete automatically when i change the value in column 8.
This piece of code below works, but only when i change 1 cell(in column 8) at the time. It doesn't work when i paste multiple Cells in Column 8 or when i select a cell in column 8 and then drag it down(from the lower right corner).
I don't have a lot of experience with coding and just can't seem to find the right solution for this.
Thanks to QHarr i got a bit further.
This is my second attempt:
Dim ClearC9 As String
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then GoTo ClearC9
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
Next i
exitHandler:
Application.EnableEvents = True
Columns("I:I").EntireColumn.AutoFit
ClearC9:
Selection.Offset(, 1).ClearContents
First Attempt:
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
This is the entire code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 9 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal & ", ", "")
End If
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
End If
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
Next i
exitHandler:
Application.EnableEvents = True
Columns("I:I").EntireColumn.AutoFit
End Sub

The general pattern to to create an intersection range:
if it is Nothing then do nothing
otherwise loop over its cells
for example:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range, TheIntersection As Range, r As Range
' stuff
TheIntersection = Intersect(Target, rngDV)
If TheIntersection Is Nothing Then
' do nothing
Else
For Each r In TheIntersection
' do something
Next r
End If
End Sub

Related

Set Variable equal to multiple selected cells

I am attempting to get my code to work when multiple cells are selected/changed. I'm not too sure where to go from here as I'm having trouble setting a variable to a target when the target is a multi-cell selection.
An example of what I need would be: All cells in column 1 are selected and deleted, so subsequently I want all cells in column 2 to also be deleted. Instead the code returns an error and does not delete column 2 for any of the selected rows.
Here is the code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Target.Column = 1 Then
Application.EnableEvents = False
Dim OldValue As String
Dim NewValue As String
NewValue = Target.Value
Application.Undo
OldValue = Target.Value
Target.Value = NewValue
Application.EnableEvents = True
If OldValue = "" Then
Exit Sub
Else
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
MsgBox "Contents related to this drop-down have been cleared"
End If
End If
Exithandling:
Application.EnableEvents = True
Exit Sub
Application.ScreenUpdating = True
End Sub
Something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, oldVal, newVal, i As Long, num As Long, c As Range
On Error GoTo haveError:
'only process the part of Target which overlaps with ColA...
Set rng = Application.Intersect(Target, Me.Columns(1))
'run some checks before proceeding...
If rng Is Nothing Then Exit Sub
If rng.Cells.Count = Me.Columns(1).Cells.Count Then Exit Sub 'ignore full-column operations
If rng.Areas.Count > 1 Then Exit Sub 'handling multiple areas will be more complex...
If Application.CountBlank(rng) = 0 Then Exit Sub 'no empty cells: nothing to do here
Application.EnableEvents = False
newVal = GetArray(rng)
Application.Undo
oldVal = GetArray(rng)
rng.Value = newVal
For Each c In rng.Cells
i = i + 1
If newVal(i, 1) = "" And oldVal(i, 1) <> "" Then
c.Offset(0, 1).ClearContents
num = num + 1
End If
Next c
If num > 0 Then MsgBox "Contents related to drop-down(s) have been cleared"
haveError:
If Err <> 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub
'normalizes the array vs. scalar returned when calling .Value
' on a multi- vs. single-cell range
Function GetArray(rng As Range)
Dim arr
If rng.Count > 1 Then
arr = rng.Value
Else
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value
End If
GetArray = arr
End Function

VBA save value from cell before it changes

I have a spreadsheet where i implement a score board.
The behavior i need is when the cell that has the score value rises the cell near it, on column b, changes it's color to green, when the the cell score value goes down the cell near it changes it's color to red.
The cell range where the score is changing is e5:e67
In short:
When the user inputs a number in column f, the score raises in column e, and in column b (on same row) the color must change to green or red
I made this VBA code, but without luck.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("e5:e67")) Is Nothing Then
If Target.Column = 5 Then
thisRow = Target.Row
Dim OldValue As Variant
Application.EnableEvents = False
Application.Undo
OldValue = Target.Value
Application.Undo
Application.EnableEvents = True
If OldValue < Target.Value Then
Range("b" & thisRow).Interior.ColorIndex = 4
ElseIf OldValue > Target.Value Then
Range("b" & thisRow).Interior.ColorIndex = 3
End If
End If
End If
End Sub
Here is a screen capture of my ranking sheet:
Try by intercepting the Worksheet_Calculate event. You need to save the old value in a static local array, that I call oldVal.
Private Sub Worksheet_Calculate()
Static oldVal
If IsEmpty(oldVal) Then
oldVal = Application.Transpose(Range("e5:e67").Value2)
ReDim Preserve oldVal(5 To 67)
Exit Sub
End If
Dim i As Long
For i = LBound(oldVal) To UBound(oldVal)
If oldVal(i) > Cells(i, "E").Value2 Then Cells(i, "B").Interior.ColorIndex = 3
If oldVal(i) < Cells(i, "E").Value2 Then Cells(i, "B").Interior.ColorIndex = 4
oldVal(i) = Cells(i, "E").Value2
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Not Intersect(Target, Range("e6:e67")) Is Nothing Then
If Target.Offset(-1) < Target Then
i = 4
Else
i = 3
End If
Range("b" & Target.Row).Interior.ColorIndex = i
End If
End Sub

Timestamp each line that's changed when multiple cells are changed together (e.g. using Autofill)

Screen shot of what I want:
I want to time stamp each line as a change gets made so I can upload to a central file all lines that have been updated after a certain time. Since one asset might have multiple rows for each sub component, the user can fill in one line and autofill/copy paste to the relevant lines beneath. The rows might not be in a continuous range (e.g. when filtered).
The code I've got works great for changing one cell at a time and it works for a range but incredibly slowly.
This sub is called by worksheet_change shown in full below.
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol, LastInputCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
For Each TargetRng In Target.Cells
If TargetRng.Cells.Count > 1 Then
Application.EnableEvents = True
Exit Sub
Else
Application.EnableEvents = False
Cells(TargetRng.Row, LastCol - 2) = Now()
Cells(TargetRng.Row, LastCol - 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Value = Target.Address
End If
Next
Application.EnableEvents = True
End Sub
Target.Cells.Address returns the range (including non-visible cells), but I can't work out how to split this into individual, visible cells that I can loop through.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorcatch
Dim TargetRng As Range
Dim LastCol, LastInputCol, LastRow As Integer
Dim LastInputColLetter As String
Dim ContinueNewRow
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
LastInputCol = LastCol - 3
If LastInputCol > 26 Then
LastInputColLetter = Chr(Int((LastInputCol - 1) / 26) + 64) & Chr(((LastInputCol - 1) Mod 26) + 65)
Else
LastInputColLetter = Chr(LastInputCol + 64)
End If
For Each TargetRng In Target.Cells
If TargetRng.Row <= 2 Then
Exit Sub
End If
If TargetRng.Column <= LastInputCol Then
SetDateRow Target, LastCol - 3
If TargetRng.Count = 1 Then
Application.EnableEvents = False
'
Dim cmt As String
' If Target.Value = "" Then
' Target.Value = " "
'
' End If
'----------------------------------------------------------------
If Intersect(TargetRng, Range("AC3:AC10000")) Is Nothing Then ' need to make column into variables in the code based on column name
Application.EnableEvents = True
Else
Application.EnableEvents = False
Cells(TargetRng.Row, "Z") = Now() 'Date booking was made column
Cells(TargetRng.Row, "AD").Value = Cells(Target.Row, "AD").Value + 1 ' iteration column
End If
'----------------------------------------------------------------
If TargetRng.Comment Is Nothing Then
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "*"
Else
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "* " & TargetRng.Comment.Text
End If
With TargetRng
.ClearComments
.AddComment cmt
End With
End If
End If
Application.EnableEvents = True
Next
Exit Sub
Errorcatch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I have done some adjustments to your code (see comments within code)
This solution assumes the following:
Sample data has a two rows header and fields to be updated have the following titles located at row 1 (adjust corresponding lines in code if needed):
Date Change Made, Who Made Change and Last Cell Changed as per picture provided.
Booked Date, BkdDte Change and Iteration for columns AC, Z and AD respectively (this names are used for testing purposes, change code to actual names)
I have also combined both procedures into a common one in order to avoid the inefficient approach of looping twice the cells of the changed range. Let me know if they must remain separated and will do the necessary adjustments.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh As Worksheet, rCll As Range
Dim iDteChn As Integer, iWhoChn As Integer, iLstCll As Integer
Dim iBkdDte As Integer, iBkdChn As Integer, iBkdCnt As Integer
Dim sCllCmt As String
Dim lRow As Long
On Error GoTo ErrorCatch
Rem Set Application Properties
Application.ScreenUpdating = False 'Improve performance
Application.EnableEvents = False 'Disable events at the begining
Rem Set Field Position - This will always returns Fields position
Set Wsh = Target.Worksheet
With Wsh
iDteChn = WorksheetFunction.Match("Date Change Made", .Rows(1), 0)
iWhoChn = WorksheetFunction.Match("Who Made Change", .Rows(1), 0)
iLstCll = WorksheetFunction.Match("Last Cell Changed", .Rows(1), 0)
iBkdDte = WorksheetFunction.Match("Booked Date", .Rows(1), 0) 'Column of field "Booked date" (i.e. Column `AC`)
iBkdChn = WorksheetFunction.Match("BkdDte Change", .Rows(1), 0) 'Column of field "Booked date changed" (i.e. Column `Z`)
iBkdCnt = WorksheetFunction.Match("Iteration", .Rows(1), 0) 'Column of field "Iteration" (i.e. Column `AD`)
End With
Rem Process Cells Changed
For Each rCll In Target.Cells
With rCll
lRow = .Row
Rem Exclude Header Rows
If lRow <= 2 Then GoTo NEXT_Cll
Rem Validate Field Changed
Select Case .Column
Case Is >= iLstCll: GoTo NEXT_Cll
Case iDteChn, iWhoChn, iBkdChn, iBkdCnt: GoTo NEXT_Cll
Case iBkdDte
Rem Booked Date - Set Count
Wsh.Cells(lRow, iBkdChn) = Now()
Wsh.Cells(lRow, iBkdCnt).Value = Cells(.Row, iBkdCnt).Value + 1
End Select
Rem Update Cell Change Details
Wsh.Cells(lRow, iDteChn).Value = Now()
Wsh.Cells(lRow, iWhoChn).Value = Environ("username")
Wsh.Cells(lRow, iLstCll).Value = .Address
Rem Update Cell Change Comments
sCllCmt = Now & vbCrLf & Environ("UserName") & " *" & .Value & "*"
If Not .Comment Is Nothing Then sCllCmt = sCllCmt & .Comment.Text
.ClearComments
.AddComment sCllCmt
End With
NEXT_Cll:
Next
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorCatch:
MsgBox Err.Description
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Do let me know of any questions you might have about the resources used in this procedure.
You could use something like this:
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol As Long
Dim LastInputCol As Long
Dim bEvents As Boolean
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
bEvents = Application.EnableEvents
Application.EnableEvents = False
If Target.Cells.Count > 1 Then
For Each TargetRng In Target.SpecialCells(xlCellTypeVisible).Areas
Cells(TargetRng.Row, LastCol - 2).Resize(TargetRng.Rows.Count, 1).Value = Now()
Cells(TargetRng.Row, LastCol - 1).Resize(TargetRng.Rows.Count, 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Resize(TargetRng.Rows.Count, 1).Value = Target.Address
Next
Else
Cells(Target.Row, LastCol - 2).Value = Now()
Cells(Target.Row, LastCol - 1).Value = Environ("username")
Cells(Target.Row, LastCol).Value = Target.Address
End If
Application.EnableEvents = bEvents
End Sub
but make sure you call it before or after the loop in your change event, not inside it as you are now!

Auto Formatting Race Result Times

I have started creating a VBA Macro that helps me add formatting to rows as I add them with a custom NumberFormat. But since My partner and I sometimes Enter item like "ss.00" and this messed up the cell. So I started writing out another Sub where it checks if its missing the semicolon. How can I add "0:" to the front of this value automatically where the cell would show "0:50.20", Everytime I do it, it ends up being a long number.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Cells.Count = 1 Then
If Target.Column = 1 Then
If Target.Row < 24 And Target.Row > 1 Then
Set FirstRow = Target.Offset(0, 1)
Set LastRow = Target.Offset(0, 11)
If Target.Value <> "" Then
For Each Cel In Range(FirstRow, LastRow)
Cel.NumberFormat = "m:ss.00;#"
Next
Else
If MsgBox("This will erase the row! Are you sure?", vbYesNo) = vbNo Then
Exit Sub
Else
For Each Cel In Range(FirstRow, LastRow)
Cel.ClearContents
Next
End If
End If
End If
End If
Const sCheckAddress As String = "B2:L24"
Dim rngIntersect As Range
On Error Resume Next
Set rngIntersect = Intersect(Me.Range(sCheckAddress), Target)
On Error GoTo 0
If Not (rngIntersect Is Nothing) Then
If Target.Value2 <> "" Then
If InStr(Target.Value2, ":") < 1 Then
End If
End If
End If
End If
End Sub
Maybe this would help you :
If InStr(Target.Value2, ":") < 1 Then
' ":" not found
Target.Value = CStr("0:" & Target.Value)
Else
' ":" found
'Nothing to add
End If

Excel VBA-Duplicates run with button/add location

I am new to Excel VBA and I really need your help. I have a code that will look for the duplicate values in Column A. This code will highlight the duplicate values. I want:
1.) This code to ONLY run when I click on a button.
2.) I would like to have (somewhere in the same worksheet), the number of duplicate results and a hyper link that when you click on it will direct you the duplicate result (this is because I have sometimes huge files that I need to validate). Here is the code I currently have:
Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim C As Range, i As Long
If Not Intersect(Target, Me.[A:A]) Is Nothing Then
Application.EnableEvents = False
For Each C In Target
If C.Column = 1 And C.Value > "" Then
If WorksheetFunction.CountIf(Me.[A:A], C.Value) > 1 Then
i = C.Interior.ColorIndex
f = C.Font.ColorIndex
C.Interior.ColorIndex = 3 ' Red
C.Font.ColorIndex = 6 ' Yellow
C.Select
MsgBox "Duplicate Entry !", vbCritical, "Error"
C.Interior.ColorIndex = i
C.Font.ColorIndex = f
End If
End If
Next
Application.EnableEvents = True
End If
End Sub
I would really appreciate it if you help me with this.
Add the code to Module1 Alt+F11
Option Explicit
Sub MyButton()
Dim RangeCell As Range, _
MyData As Range
Dim MyDupList As String
Dim intMyCounter As Integer
Dim MyUniqueList As Object
Dim lngLastRow As Long, lngLoopRow As Long
Dim lngWriteRow As Long
Set MyData = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set MyUniqueList = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
MyDupList = "": intMyCounter = 0
'// Find Duplicate
For Each RangeCell In MyData
If RangeCell <> "V" And RangeCell <> "R" Then
If Evaluate("COUNTIF(" & MyData.Address & "," & RangeCell.Address & ")") > 1 Then
'// Color. Change to suit RGB(141, 180, 226).
RangeCell.Interior.Color = RGB(141, 255, 226)
If MyUniqueList.exists(CStr(RangeCell)) = False Then
intMyCounter = intMyCounter + 1
MyUniqueList.Add CStr(RangeCell), intMyCounter
If MyDupList = "" Then
MyDupList = RangeCell
Else
MyDupList = MyDupList & vbNewLine & RangeCell
End If
End If
Else
RangeCell.Interior.ColorIndex = xlNone
End If
End If
Next RangeCell
'// Move duplicate from Column 1 to Column 7 = (G:G)
lngWriteRow = 1
lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lngLoopRow = lngLastRow To 1 Step -1
With Cells(lngLoopRow, 1)
If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), .Value) > 1 Then
If Range("G:G").Find(.Value, lookat:=xlWhole) Is Nothing Then
Cells(lngWriteRow, 7) = .Value
lngWriteRow = lngWriteRow + 1
End If
End If
End With
Next lngLoopRow
Set MyData = Nothing: Set MyUniqueList = Nothing
Application.ScreenUpdating = False
If MyDupList <> "" Then
MsgBox "Duplicate entries have been found:" & vbNewLine & MyDupList
Else
MsgBox "There were no duplicates found in " & MyData.Address
End If
End Sub
.
Add Module
Add Button
Assign to Macro