Deleting values inside cells - excel

I have a spreadsheet for inserting values of scores of different teams. Column A has the team names and column B has their scores. The same goes for column C and D. There are 10 teams with 5 in Column A and C. My goal is to code when you enter a score for a team it goes two to the right and when you enter that value, it goes down one and left two. I had that working before, but I had to implement one more thing, and it stopped working. I had to implement that when an invalid score is entered, a non-number, negative number, etc. it would delete itself. I am not sure what I did wrong or what may have led me in the wrong direction.
Here's What I Have
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TeamScore2 As Integer
Dim TeamScore4 As Integer
Select Case Target.Column
Case 2: Target.Offset(0, 2).Select
Case 4: Target.Offset(1, -2).Select
End Select
TeamScore2 = ActiveCell.Offset(0, 2).Value
TeamScore4 = ActiveCell.Offset(1, -2).Value
If TeamScore2 <= -1 Then
ActiveCell.Value = ""
End If
If TeamScore4 <= -1 Then
ActiveCell.Value = ""
End If
End Sub
image of spreadsheet
final statments
I declared two integers and when the selected cell depending on the offset, either (0, 2) or (1, -2) was less than or equal to -1 then the value should be "". Also, I am not sure how I would implement the case that the value is a string. Also, someone said this question was already answered with a link, but I was not able to interpret it as its idea was different than my intentions.

A Worksheet Change: Teams and Scores
In cell B8 you could use something like
=IF(COUNT(B3:B7,D3:D7)=10,"Yes","No")
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const rgAddress As String = "B3:B7,D3:D7"
Const MinNum As Long = 0
Const MaxNum As Long = 100
Dim srg As Range: Set srg = Range(rgAddress)
Dim irg As Range: Set irg = Intersect(srg, Target)
If irg Is Nothing Then Exit Sub
Dim iCell As Range
Dim ValidCell As Range
Dim InvalidCells As Range
Dim iValue As Variant
Dim IsValid
For Each iCell In irg.Cells
iValue = iCell.Value
If VarType(iValue) = vbDouble Then ' number
If iValue = Int(iValue) Then ' whole number
If iValue >= MinNum And iValue <= MaxNum Then ' in range
Set ValidCell = iCell
IsValid = True
End If
End If
End If
If IsValid Then
IsValid = False
Else
If InvalidCells Is Nothing Then
Set InvalidCells = iCell
Else
Set InvalidCells = Union(InvalidCells, iCell)
End If
End If
Next iCell
If InvalidCells Is Nothing Then
Dim ColOffset As Long
ColOffset = srg.Areas(2).Column - srg.Areas(1).Column
If Intersect(ValidCell, srg.Areas(1)) Is Nothing Then
ValidCell.Offset(1, -ColOffset).Select
Else
ValidCell.Offset(, ColOffset).Select
End If
Else
Application.EnableEvents = False
InvalidCells.Value = Empty
Application.EnableEvents = True
InvalidCells.Cells(1).Select
End If
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

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

Record Date values based on another cell's value

I am a beginner in VBA.
I have a Column "A" can have multiple values, of which 2 are "Impact Assessed" or "Ready for retesting".
Problem Statement - I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively.
Below is my code -
Private Sub Worksheet_Calculate()
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("AA:AA"), Target)
If Not rng Is Nothing Then
Select Case (rng.Value)
Case "2 - Impact Assessed": rng.Offset(0, 1).Value = Date
Case "4 - Ready for retesting": rng.Offset(0, 2).Value = Date
End Select
End If
End Sub
I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the Criteria variable to suit your worksheet and you can change your sheet as you like without needing to modify the code.
Private Sub Worksheet_Change(ByVal Target As Range)
' 040
Const TriggerClm As String = "A" ' change to suit
Const WriteToClm As String = "B" ' the second one is next to this
Dim Rng As Range ' working range
Dim C As Long ' WriteToClm
Dim Criteria() As String ' selected values from TriggerClm
Dim i As Integer ' index to Criteria()
' don't respond to changes of multiple cells such as Paste or Delete
If Target.CountLarge > 1 Then Exit Sub
' respond to changes in cells from row 2 to
' one cell below the last used row in the trigger column
Set Rng = Range(Cells(2, TriggerClm), _
Cells(Rows.Count, TriggerClm).End(xlUp).Offset(1))
If Not Application.Intersect(Rng, Target) Is Nothing Then
' intentionally all lower case because comparison
' is carried out case insensitive
' First item's date is in WriteToClm
Criteria = Split("impact assessed,ready for retesting", ",")
For i = UBound(Criteria) To 0 Step -1
If StrComp(Target.Value, Criteria(i), vbTextCompare) = 0 Then Exit For
Next i
' i = -1 if no match was found
If i >= 0 Then
C = Columns(WriteToClm).Column + i
Cells(Target.Row, C).Value = Date
End If
End If
End Sub
You can use something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("A:A"), Target)
If Not rng Is Nothing Then
For Each c in rng.cells
Select Case LCase(c.Value)
Case "impact assessed": c.Offset(0, 1).Value = Date
Case "ready": c.Offset(0, 2).Value = Date
End Select
Next c
End If
End Sub
FYI = Range(Target.Address) is the same (in this case) as Target - no need to get the address just to turn that back into a range.

Get row number of first empty cell in column and store that value in other cell

I want to find row number of first empty cell in column and store that row number in Cell Z1.
I tried with Following macro code but it goes into loop forever.
As soon as it tries to set the value in Cell Z1 it again goes into worksheet_change event again and then again in for loop.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(3).Cells
If IsEmpty(cell) = True Then Range("$Z$1").Value = cell.Row: Exit For
Next cell
End Sub
Please help to resolve this.
Thanks
Maybe this code is of any help
Option Explicit
Function firstEmptyCell(col As Long, Optional ws As Worksheet) As Range
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
Set firstEmptyCell = rg
End Function
And the Event code is
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EH
If Target.Column <> 12 Then
Exit Sub
End If
Application.EnableEvents = False
Range("Z1").Value = firstEmptyCell(12).Row
EH:
Application.EnableEvents = True
End Sub
Update: Based on the comments regarding the pitfalls of the change event one could change firstEmptyCell slightly and use a UDF only
Function firstEmptyCellA(col As Long, Optional ws As Worksheet) As Long
On Error GoTo EH
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Application.Volatile
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
firstEmptyCellA = rg.Row
Exit Function
EH:
firstEmptyCellA = 0
End Function
Tricky Enable Events
This is triggered only when a cell in the 12th column (L) is changed, otherwise there is no need for it. If you have formulas there, then this will not work and you'll have to use the Worksheet_Calculate event.
Row of First Empty Cell in Column
Option Explicit
' Row of First Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="", _
After:=Cells(Rows.Count, TargetColumn), LookIn:=xlValues)
If rng Is Nothing Then
Range(TargetCell).Value = 0 ' Full column. No empty cells.
Else
Range(TargetCell).Value = rng.Row
End If
Application.EnableEvents = True
End Sub
Row of First Empty Cell After Last Non-Empty Cell in Column
Option Explicit
' Row of First Empty Cell After Last Non-Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then ' Empty column. No non-empty cells.
Range(TargetCell).Value = 1
Else
If rng.Row = Rows.Count Then ' Last (bottom-most) cell is not empty.
Range(TargetCell).Value = 0
Else
Range(TargetCell) = rng.Offset(1).Row
End If
End If
Application.EnableEvents = True
End Sub
Dont need a loop. Paste this in a module not in a worksheet event unless you want it for every worksheet change.
Sub Macro1()
ActiveSheet.Range("Z1") = ActiveSheet.Columns(3).SpecialCells(xlCellTypeBlanks)(1).Row
End Sub
if you want it after every change then put it in a worksheet as. This code will not run everytime. It will check if Z1 is empty then enter the valu. Then if Z1 is not empty it will check if the target cell is in column C
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = ActiveSheet.Columns(3)
If IsEmpty(Range("Z1")) Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
Else
If Not Intersect(Range("C1:C" & Range("Z1").Value), Target) Is Nothing Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
End If
End If
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