Given this spreadsheet
I am trying to track how many times a disk gets checked out. This the VBA I converted to check Rows instead of Columns. I copied this code from one of robinCTS posts and changed it. The problem I am seeing, when a value in cell B3 get changed, Cell B8 gets 1 added to it (Correct). If I change a value in cell D13, again cell D8 is updated (InCorrect, it should be cell D18). It is in the proper column, just the wrong row.
'============================================================================================
' Module : <The appropriate sheet module>
' Version : 1.0
' Part : 1 of 1
' References : N/A
' Source : https://stackoverflow.com/a/47405528/1961728
'============================================================================================
Option Explicit
Private Sub Worksheet_Change _
( _
ByVal Target As Range _
)
Const s_CheckRow As String = "3:3,13:13"
Const s_CountRow As String = "8:8,18,18"
If Intersect(Target, Range(s_CheckRow)) Is Nothing Then Exit Sub
Dim rngCell As Range
For Each rngCell In Intersect(Target, Range(s_CheckRow))
With Range(s_CountRow).Cells(rngCell.Column)
.Value2 = IIf(.Value2 <> vbNullString, .Value2 + 1, IIf(rngCell.Value2 <> vbNullString, 1, vbNullString))
End With
Next rngCell
End Sub
So what I am doing wrong?
Instead of Const s_CountRow As String = "8:8,18,18" (typo there?) I'd use a fixed offset from each changed cell:
Private Sub Worksheet_Change(ByVal Target As Range)
Const RNG_CHECK As String = "3:3,13:13"
Const ROW_OFFSET As Long = 5
Dim rng As Range, c As Range
Set rng = Application.Intersect(Target, Range(RNG_CHECK))
If rng Is Nothing Then Exit Sub
For Each c In rng.Cells
If Len(c.Value) > 0 Then
c.Offset(ROW_OFFSET).Value = c.Offset(ROW_OFFSET).Value + 1
End If
Next c
End Sub
Related
I have an excel file, all the cells of the column A contain a value (numerical value), then there is the column B, which contains other values.
I would like to write a script in vba (or also other options, if there are alternatives) to control the change the values in column A.
To be clear, the excel user can change the cell A1 only if the cell B1 has a value equal to zero.
The same for the following rows, so the row A2 can be changed only if B2 is equal to zero, and so on.
I have searched on internet but I can't find a good solution, in particular because this must work on a large number of cells.
Thanks
Please, copy the next event code in the respective sheet code module, and play with changing:
Option Explicit
Private newVal
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.cells.count > 1 Then Exit Sub
If Target.column = 1 Then
If Target.Offset(, 1).Value <> 0 Then
Application.EnableEvents = False 'to avoind triggering again the Change event
newVal = Target.Value
Application.Undo
Application.EnableEvents = True
End If
End If
End Sub
You can use Data validation for this:
Select the range (ex: A1:A10)
Go to Data -> Data tools -> Data Validation
Choose the following options:
Allow "Custom"
Formula: =B1:B10=0
A Worksheet Selection Change: Restrict Column Access
With the current setup (A2, B), the following will allow access to column A (more accurately, to A2:A1048576) only if a single cell is to be selected and the cell in the same row of column B is equal to 0.
Optionally, if you choose the out-commented If statement, it will also allow access if the cell in column B is empty.
An empty cell is also numeric and equal to 0. It isn't of type Double though, but of type Empty.
Sheet Module e.g. Sheet1 (Not Into ThisWorkbook or Standard Module e.g. Module1)
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const TGT_FIRST_CELL As String = "A2"
Const SRC_COLUMN As String = "B"
Dim trg As Range
With Me.Range(TGT_FIRST_CELL)
Set trg = .Resize(Me.Rows.Count - .Row + 1)
End With
Dim irg As Range: Set irg = Intersect(trg, Target)
If irg Is Nothing Then Exit Sub
Dim ColumnOffset As Long
ColumnOffset = Me.Columns(SRC_COLUMN).Column - irg.Column
Dim srg As Range: Set srg = irg.Offset(, ColumnOffset)
If srg.Cells.Count = 1 Then
Dim sValue As Variant: sValue = srg.Value
If VarType(sValue) = vbDouble Then ' write just if 0
' or:
'If IsNumeric(sValue) Then ' write if 0 or empty
If sValue = 0 Then Exit Sub
End If
End If
srg.Cells(1).Select
End Sub
Foe example, When User enters a value in A6 and press enter, cursor should move to G6. When the user enter the value in G6 the cursor should move to A7. user enter value again, cursor moves to G7. this should repeat A8 to G8, A9 to G9.
I have created a small VBA code with help of my friend! Any modification to this code will be much helpful!
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$5" Then Range("G5").Select
End Sub
You can change the code to :
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Target.Offset(0, 6).Select
ElseIf Target.Column = 7 Then
Target.Offset(1, -6).Select
End If
End Sub
However, If the user don't modify anything in a cell and just pressed Tab, the cursor will still jump to the next cell because the Change-Event is not triggered.
Alternative (without code): Format the columns A and G: Remove the flag "Locked" from the Protection Tab of the Format Dialog. All other cells should be locked. Not protect your worksheet (Review->Protect sheet).
Alternating Cursor Down
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const rgAddress As String = "A:A,G:G"
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 arg As Range: Set arg = irg.Areas(irg.Areas.Count)
Dim iCell As Range: Set iCell = arg.Cells(arg.Rows.Count, arg.Columns.Count)
Dim Col1 As Long: Col1 = srg.Areas(1).Column
Dim Col2 As Long: Col2 = srg.Areas(2).Column
If iCell.Column = Col1 Then
iCell.Offset(, Col2 - Col1).Select
Else
If iCell.Row = Rows.Count Then
Cells(1, Col1).Select
Else
Cells(iCell.Row + 1, Col1).Select
End If
End If
End Sub
I would define the columns to check as const - in case there is a change to the sheet.
Then write a function that implements your logic:
if change in first column jump to second column in same row
if change in second column jump one row down back to column 1
I prefer to write seperate functions/subs to be called from within the sheet-events.
If they have good names it's clear what you want to achieve without reading the code itself.
Or maybe you can re-use them from different sheets if you put them in a general module.
Option Explicit
Private Const col1ToCheck As String = 1 'column A
Private Const col2ToCheck As String = 7 'column G
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cSource As Range: Set cSource = Target.Cells(1, 1)
If cSource.Column = col1ToCheck Or cSource.Column = col2ToCheck Then
nextCellSpecial(cSource).Select
End If
End Sub
'this function implements your "jump"-logic
Private Function nextCellSpecial(cSource As Range) As Range
Dim diffCol1ToCol2 As Long
diffCol1ToCol2 = col2ToCheck - col1ToCheck
If cSource.Column = col1ToCheck Then
'nextCell = offset to column 2
Set nextCellSpecial= cSource.Offset(, diffCol1ToCol2)
ElseIf cSource.Column = col2ToCheck Then
'nextCell = colName1 next row
Set nextCellSpecial= cSource.Offset(1, -diffCol1ToCol2)
Else 'in case this function is re-used for other purposes
Set nextCellSpecial= cSource
End If
End Function
I know about conditional formatting, but it doesn't give me the options I'm looking for: namely, the possibility to manually change the cell fill color (in affected cells) based on how a color another cell, and with that, a standard fill color if I don't do anything. I have this VBA code for a single row (see below) and it works, though I have a feeling it's complicated in itself. Now, I want the same thing for another 149 rows, but the code obviously gets to complex. How can I achieve this? Is it wrong to put this in a SelectionChange?
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cell As Range
For Each Cell In Range("F7:PB7")
If Cell.Value < Range("D8").Value Or Cell.Value > Range("E8").Value Then
Cell.Offset(1, 0).Interior.ColorIndex = 0
End If
If Cell.Value >= Range("D8").Value And Cell.Value <= Range("E8").Value Then
If Range("B8").Interior.ColorIndex < 0 Then
Cell.Offset(1, 0).Interior.ColorIndex = 15
Else
If Range("B8").Interior.ColorIndex >= 0 Then
Cell.Offset(1, 0).Interior.Color = Range("B8").Interior.Color
End If
End If
End If
... et cetera next row ...
Next Cell
End Sub
Best regards!
Try this out. I'm getting the default color for each row from ColA.
This is all in the worksheet code module:
Option Explicit
Const RW_DATES As Long = 7 'row with headers and dates
Const COL_NAME As Long = 2 'column with person's name
Const COL_START_DATE As Long = 4 'column with start date
Const COL_DATE1 As Long = 6 '1st date on header row
Const NUM_ROWS As Long = 150 'how many rows?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, rng As Range, rngDates As Range, i As Long
Dim startDate, endDate, rw As Range, arrDates, rngRowDates As Range
Dim CheckAll As Boolean, hiliteColor As Long, hiliteName As String
Dim cName As Range, selName, selColor As Long
CheckAll = Target Is Nothing 'called from selection_change?
If Not CheckAll Then
'Was a cell changed? see if any start/end date cells were changed
Set rng = Application.Intersect(Target, _
Me.Cells(RW_DATES + 1, COL_START_DATE).Resize(NUM_ROWS, 2))
If rng Is Nothing Then Exit Sub 'nothing to do in this case
Else
'called from Selection_change: checking *all* rows
Set rng = Me.Cells(RW_DATES + 1, COL_START_DATE).Resize(NUM_ROWS)
End If
Debug.Print "ran", "checkall=" & CheckAll
'header range with dates
Set rngDates = Me.Range(Me.Cells(RW_DATES, COL_DATE1), _
Me.Cells(RW_DATES, Columns.Count).End(xlToLeft))
arrDates = rngDates.Value 'read dates to array
Set cName = NameHiliteCell() 'see if there's a hilited name
If Not cName Is Nothing Then
selName = cName.Value
selColor = cName.Interior.Color
End If
'loop over each changed row
For Each rw In rng.EntireRow.Rows
Set rngRowDates = rw.Cells(COL_DATE1).Resize(1, rngDates.Columns.Count)
rngRowDates.Interior.ColorIndex = xlNone 'clear by default
startDate = rw.Cells(COL_START_DATE).Value 'read the dates for this row
endDate = rw.Cells(COL_START_DATE + 1).Value
'determine what color the bar should be
If Len(selName) > 0 And selName = rw.Cells(COL_NAME).Value Then
hiliteColor = selColor
Else
hiliteColor = rw.Cells(1).Interior.Color
End If
If startDate > 0 And endDate > 0 Then
i = 0
For Each c In rngRowDates.Cells
i = i + 1
If arrDates(1, i) >= startDate And arrDates(1, i) <= endDate Then
c.Interior.Color = hiliteColor
End If
Next c
End If
Next rw
End Sub
'just calls Worksheet_Change; add some delay to reduce frequency of firing
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static lastrun As Date
If lastrun = 0 Then lastrun = Now
If Now - lastrun > (1 / 86400) Then
lastrun = Now
Worksheet_Change Nothing
End If
End Sub
'find the first name cell which has any fill and return it
Function NameHiliteCell() As Range
Dim c As Range
For Each c In Me.Cells(RW_DATES + 1, COL_NAME).Resize(NUM_ROWS)
If Not c.Interior.ColorIndex = xlNone Then
Set NameHiliteCell = c
Exit Function
End If
Next c
End Function
My test range:
Would something like this be better? It will only fire when you change a value in the range F7:PB7.
It won't fire if the cell value is updated through a formula (for that you'd want to look at the cell that you changed to make the formula update).
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count = 1 Then 'Only fire if a single cell is changed.
If Not Intersect(Target, Range("F7:PB154")) Is Nothing Then
MsgBox Target.Address 'Test
'Your code - looking at Target rather than each Cell in range.
End If
End If
End Sub
Edit: Updated the range so it looks at more than one row, but now thinking I should delete the answer due to the odd/even rows that #Cyril indicates, etc.... this isn't looking like a complete answer now.
How can I force user to enter negative number in Excel?
Basically column A can only be "W" or "X". Whenever column A has "W", i want column B to reflect a negative number, even if the user has keyed in a positive number.
"W" in column A corresponds to a negative value in column B
"X" in column B corresponds to a positive value in column B.
Thanks for the help!
No VBA needed. Just use data validation with the following formula
=OR(AND(A1="W",B1<0),AND(A1="X",B1>0))
Image 1: Using data validation W in column A only allows negatives in column B, X in column A only allows positives in column B.
Install the code below in the code module of the worksheet on which you want to control the input. It's a module that already exists in your VB Project. Any module you have to create is the wrong one and won't work. Look for a module with a double name like Sheet1 (Sheet1).
Private Sub Worksheet_Change(ByVal Target As Range)
' 058
Dim Rng As Range
Dim Numb As Variant
Dim NewNumb As Double
' ignore changes to more than one cell (such as pasting)
If Target.CountLarge > 1 Then Exit Sub
' this range starts in A2 and covers all used cells in columns A:B
Set Rng = Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)) _
.Resize(, 2)
' skip if the changed cell is not within the defiend range
If Not Application.Intersect(Target, Rng) Is Nothing Then
' take no action of the value in column A isn't "X" or "W"
With Target
Numb = Cells(.Row, "B").Value
' take no action if the cell in column B has no value
If Numb Then
If Cells(.Row, "A").Value = "W" Then
NewNumb = Abs(Val(Numb)) * -1
ElseIf Cells(.Row, "A").Value = "X" Then
NewNumb = Abs(Val(Numb))
End If
' prevent changes made from calling this procedure
Application.EnableEvents = False
' don't take action if the value in column A
' was neither X nor W
If Numb And (Numb <> NewNumb) Then _
Cells(.Row, "B").Value = NewNumb
Application.EnableEvents = True
End If
End With
End If
End Sub
The code works on columns A and B. To modify these targets isn't difficult. For now, when a cell in either column is changed the procedure may take action. For the rules by which it will not take action please read the comments in the code. When it does take action it will make sure that any entry in column B is negative if the letter in column A is W and positive when it's X, regardless of what sign the user entered.
A little VBA in your worksheet module will take care of that:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const SourceColumn As Long = 1
Const TargetColumn As Long = 2
Const NegatorSymbol As String = "W"
Dim SourceRange As Excel.Range
Dim TargetRange As Excel.Range
Dim Sign As Long
Dim TargetValue As Long
If Target.Column = TargetColumn Then
Set SourceRange = Cells(Target.Row, SourceColumn)
If UCase(SourceRange.Value) = NegatorSymbol Then
Sign = -1
Else
Sign = 1
End If
TargetValue = Sign * Abs(Target.Value)
If Target.Value <> TargetValue Then
Target.Value = TargetValue
End If
ElseIf Target.Column = SourceColumn Then
Set TargetRange = Cells(Target.Row, TargetColumn)
If UCase(Target.Value) = NegatorSymbol Then
Sign = -1
Else
Sign = 1
End If
TargetValue = Sign * Abs(TargetRange.Value)
If TargetRange.Value <> TargetValue Then
TargetRange.Value = TargetValue
End If
End If
End Sub
You can set on column B a data validation Custom with this formula:
=OR(AND(A1="W";B1<0);AND(A1<>"W";B1>0))
[EDIT]
I was late to the party...
I have a large workbook and am trying to increase performance.
Is it possible/viable to store my formulas in some sort of list contained within the code rather than in the cells on the spreadsheet?
Variable SelectedRow = the currently selected row
For example:
ColumnBFormula = A(SelectedRow) + 1
ColumnCFormula = A(SelectedRow) + 2
If the user enters 4 in cell A3, then the macro writes formulas above ONLY in empty cells B3 and C3, then converts to values. The rest of the spreadsheet remains unchanged (should only have values everywhere).
Then the user enters a 6 in cell A4 and the spreadsheet writes the formulas to empty cells B4 and C4, calculates then converts to values.
Thanks
Try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lastrow As Long
'Refer to Sheet1
With ThisWorkbook.Worksheets("Sheet1")
'Check if Column A affected
If Not Intersect(Target, Range("A:A")) Is Nothing And IsNumeric(Target) Then
'Disable event to avoid event trigger
Application.EnableEvents = False
Target.Offset(0, 1).Value = Target + 1
Target.Offset(0, 2).Value = Target + 2
'Enable event
Application.EnableEvents = True
End If
End With
End Sub
Instructions:
Enable Events:
Given you know what you want the code to do, you could do this without entering formulas.
In the VBA editor, add this code into the "ThisWorkbook" object ...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim objCell As Range
Application.EnableEvents = False
For Each objCell In Target.Cells
If objCell.Column = 1 Then
If objCell.Value = "" Then
objCell.Offset(0, 1) = ""
objCell.Offset(0, 2) = ""
Else
objCell.Offset(0, 1) = objCell.Value + 1
objCell.Offset(0, 2) = objCell.Value + 2
End If
End If
Next
Application.EnableEvents = True
End Sub
Hopefully that works for you.
FYI - You'll need to add the relevant error checking for values if not numeric etc, it will need to be improved.