This is probably very basic for you guys, but I just started using VBA in Excel and eventhough I have a pretty good understanding of the logic behind the functions, I can't seem to find what I am looking for ...
Here is my code :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A4:A27")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Dim myValue As Variant
myValue = InputBox("Indiquer la quantité", "Quantité")
Range("C4").Value = myValue
If Cells("4", "C") > 1 Then
MsgBox (myValue & " produits sélectionnés")
End If
If Cells("4", "C") < 1 Then
End If
End If
Basically my document is a table where you select one cell after the other in range ("A4:A27"). I want the result of my InputBox to go in an Offset cell (0,2). I set "C4" so that I wouldn't get any error but obviously when I select A5 my result still goes in C4 when I would like it to go in C5....
What is the function to use ?
Thks for answers
I think you will need to use the Target cell. Does this do what you're looking for?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A4:A27")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Dim myValue As Variant
myValue = InputBox("Indiquer la quantité", "Quantité")
Range("C" & Target.Row).Value = myValue
If Cells(Target.Row, "C") > 1 Then
MsgBox (myValue & " produits sélectionnés")
End If
If Cells(Target.Row, "C") < 1 Then
End If
End If
Related
I have written the following code to input the date in the cell to the right if the active cell = 'yes' or 'no'. This part of the code is working perfectly fine but for some reason when the active cell doesn't meet the criteria then I want it to clear the content of the 2 cells to the right. Any advise would much appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will cause an input
'date and time in next 2 cells to the right when active cell is changed.
Set KeyCells = ActiveSheet.ListObjects("VW_P1_P2").ListColumns("C1 Made Contact?").Range
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target = "Yes" Or Target = "No" Then
ActiveCell.Offset(-1, 1).Value = Format(Now, "mm/dd/yyyy")
ActiveCell.Offset(-1, 2).Value = Format(Now, "hh:mm")
Else
ActiveCell.Offset(-1, 1).ClearContents
ActiveCell.Offset(-1, 2).ClearContents
End If
End If
End Sub
Several issues/improvements:
Use Me to refer to the parent worksheet, instead of ActiveSheet.
Avoid using ActiveCell, and instead use Target to refer to the changed cell(s).
Range(Target.Address) is redundant. Just use Target.
If Target is a multi-cell range, you can't compare it to "Yes" or "No", so use a loop.
You're changing the sheet programmatically, so best practice would be to temporarily disable events, and re-enable them at the end.
I'd suggest using .ListColumns("C1 Made Contact?").DataBodyRange instead of .ListColumns("C1 Made Contact?").Range. This would exclude the column header C1 Made Contact.
Instead of Format(Now, "mm/dd/yyyy"), you could just use Date.
Private Sub Worksheet_Change(ByVal Target As Range)
' The variable KeyCells contains the cells that will cause an input
'date and time in next 2 cells to the right when active cell is changed.
Dim KeyCells As Range
Set KeyCells = Me.ListObjects("VW_P1_P2").ListColumns("C1 Made Contact?").DataBodyRange
Dim rng As Range
Set rng = Application.Intersect(KeyCells, Target)
If Not rng Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell As Range
For Each cell in rng
If cell.Value = "Yes" Or cell.Value = "No" Then
cell.Offset(-1, 1).Value = Format(Now, "mm/dd/yyyy") ' or just Date
cell.Offset(-1, 2).Value = Format(Now, "hh:mm")
Else
cell.Offset(-1, 1).ClearContents
cell.Offset(-1, 2).ClearContents
End If
Next
End If
SafeExit:
Application.EnableEvents = True
End Sub
EDIT:
If KeyCells is multiple columns in your table, then you could use Union:
With Me.ListObjects("VW_P1_P2")
Dim KeyCells As Range
Set KeyCells = Union(.ListColumns("C1 Made Contact?").DataBodyRange, _
.ListColumns("C2 Made Contact?").DataBodyRange, _
.ListColumns("C3 Made Contact?").DataBodyRange)
End With
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("F2:F220")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Range("G2:G220").Value < 0 Then
MsgBox "Cell " & Target.Address & " has changed."
End If
End If
End Sub
There's a formula in column G that calculates the value from numbers in column F. I wanted a popup when a result in G has a negative value. The type mismatch is on the line If Range("G2:G220") ... The column is formatted as Number, but it shows as Variant/Variant. I assume this is because the cell contents are actually a formula?
Is there a way round this without introducing 'helper' columns?
This is only my second bit of VBA so I'm happy to hear if you spot any other errors!
Restrict the Number of Results
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const KeyAddress As String = "F2:F220"
Const CheckColumn As Variant = "G" ' e.g. "A" or 1
Const MaxResults As Long = 1
' Define 'KeyCells'.
Dim KeyCells As Range: Set KeyCells = Range(KeyAddress)
' Define the range of cells that have changed and are part of 'KeyCells'.
Dim rng As Range: Set rng = Application.Intersect(Target, KeyCells)
' Check if there are any cells that have changed and are part of 'KeyCells'.
If rng Is Nothing Then Exit Sub
' Check if there is more than 'MaxResults' cells that have changed and
' are part of 'KeyCells'.
If rng.Cells.Count > MaxResults Then GoSub checkMoreCells
' Calculate the offset between 'Key' and 'Check' columns.
Dim ColOff As Long: ColOff = Columns(CheckColumn).Column - KeyCells.Column
Dim cel As Range
For Each cel In rng.Cells
' Check if the value in 'Check' column is negative.
If cel.Offset(, ColOff).Value < 0 Then
MsgBox "Cell '" & cel.Address(False, False) & "' has changed " _
& "to '" & cel.Value & "'."
End If
Next cel
Exit Sub
checkMoreCells:
Dim msg As Variant
msg = MsgBox("There could be '" & rng.Cells.Count & "' results. " _
& "Are you sure you want to continue?", _
vbYesNo + vbCritical, _
"More Than One Cell")
If msg = vbYes Then Return
Exit Sub
End Sub
Something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
Set rng = Application.Intersect(Range("F2:F220"), Target) 'Target is already a Range...
'any changed cells in F2:F220 ?
If Not rng Is Nothing Then
'loop over the changed cell(s)
For Each c in rng.Cells
'check value in ColG...
If c.Offset(0, 1).Value < 0 Then
MsgBox "Cell " & c.Address & " has changed."
End If
Next c
End If
End Sub
Edit: I realize it's not exactly clear whether you want to know if there's any negative numbers in Col G, or if you want to track row-by-row. This code does the latter.
Currently using this macro cell template off Microsoft, it works perfectly when I input data into the B column one by one but when I try to copy and paste data into B1:B10 the macro will not run and column A will not update. Also If I wanted the same macro for another range column would I have to make another function exact same and change the Set KeyCells = Range( : ) or can I add in a conditional statement in the same function?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("B1:B1000")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Cells(Target.Row, 2).Value = "A" Then
Cells.(Target.Row, 1).Value = "AA"
End If
If Cells(Target.Row, 2).Value = "B" Then
Cells.(Target.Row, 1).Value = "BB"
End If
End If
End Sub
Loop the intersection of the target cells and the desired range.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Intersect(Range("B1:B1000"), Target)
If Not KeyCells Is Nothing Then
Dim rng As Range
For Each rng In KeyCells
If rng.Value = "A" Then
rng.Offset(0, -1).Value = "AA"
ElseIf rng.Value = "B" Then
rng.Offset(0, -1).Value = "BB"
End If
Next rng
End If
End Sub
I have a macro which prevents duplicates within the range A:H
But I don't know how to change the macro so it prevents input of "[name] [space] [surname]" more than twice. There can be a number of "[name] [space] [surname]" in one cell
Option Explicit
Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cel As Range
Dim What As Variant
Set rng = ActiveSheet.UsedRange.Columns("A:H")
If Target.Value = "" Then Exit Sub
If Not Intersect(Target, rng) Is Nothing Then
What = "*" & Target.Value & "*"
For Each cel In rng.Cells
If cel.Value Like What Then
Target.ClearContents
MsgBox "Text already present!"
End If
Next cel
End If
End Sub
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