Scenario:
I have two worksheets the same except for "some content" in Sheet2 column C-E, and Sheet1 containing a Worksheet_SelectionChange handler
When I click on column B in Sheet1 the Worksheet_SelectionChange changes the cell colour and then sets column C-E to that of Sheet2 Column C
Problem:
Trouble is it falls over on an application error...
Can anyone help please, this is really annoying...just how do i copy the data from Sheet2 to Sheet 1 in a Worksheet_SelectionChange handler?
If I set S1C = "X" (as in hardcoded it's fine), its when I try to reference the cell from the second sheet that it doesn't work.
many thanks in advance,
Best regards
Code as follows:
Public benRel
Public rskOpt
Public resOpt
Public getRow
Public getCol
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitSubCorrectly
'turn off multiple recurring changes
Application.EnableEvents = False
'do not allow range selection
If Target.Cells.Count > 1 Then GoTo ExitSubCorrectly
'only allow selection within our range
Set myRange = Range("B8:B24")
If Not Application.Intersect(Target, myRange) Is Nothing Then
' At least one cell of Target is within the range myRange.
' Carry out some action.
getRow = Target.Row
getCol = Target.Column
Select Case Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style
Case "Normal"
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style = "Accent1"
getData
putData
Case "Accent1"
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style = "Normal"
Range(Cells(Target.Row, Target.Column + 1), Cells(Target.Row, Target.Column + 3)).Value = ""
Case Else
End Select
Else
' No cell of Target in in the range. Get Out.
GoTo ExitSubCorrectly
End If
ExitSubCorrectly:
' go back and turn on changes
' MsgBox Err.Description
Worksheets("Sheet1").Select
Application.EnableEvents = True
End Sub
Sub getData()
Worksheets("Sheet2").Select
Range(Cells(getRow, getCol), Cells(getRow, getCol)).Select
benRel = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 1).Value
rskOpt = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 2).Value
resOpt = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 3).Value
End Sub
Sub putData()
Worksheets("Sheet1").Select
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 1).Value = benRel
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 2).Value = rskOpt
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 3).Value = resOpt
End Sub
it looks to me like you could replace all three routines with
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitSubCorrectly
'turn off multiple recurring changes
Application.EnableEvents = False
'do not allow range selection
If Target.Cells.Count > 1 Then GoTo ExitSubCorrectly
'only allow selection within our range
Set myRange = Range("B8:B24")
If Not Application.Intersect(Target, myRange) Is Nothing Then
' At least one cell of Target is within the range myRange.
' Carry out some action.
With Cells(Target.Row, Target.Column)
Select Case .Style
Case "Normal"
.Style = "Accent1"
.Offset(0, 1).Resize(, 3).Value = Worksheets("Sheet2").Cells(getRow, getCol).Offset(0, 1).Resize(, 3).Value
Case "Accent1"
.Style = "Normal"
.Offset(0, 1).Resize(, 3).ClearContents
Case Else
End Select
End With
End If
ExitSubCorrectly:
' go back and turn on changes
' MsgBox Err.Description
Application.EnableEvents = True
End Sub
Related
I have a worksheet change macro that highlights the first 8 cells in a row if the last cell contains the word "Cancelled". This works fine. However the word cancelled is in a drop down menu and if you accidently select it the macro kicks in. If you change to another word in the same cell, I would like it to remove the condition and go back to normal. Can someone help me out with this. Im sure it is something simple that I'm missing.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If UsedRange.Rows.Count > 0 Then
If Trim(Cells(Target.Row, Target.Column)) <> "" And _
UCase(Cells(Target.Row, Target.Column)) = "CANCELLED" Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Interior.Color = vbRed
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Font.Color = vbWhite
ElseIf Trim(Cells(Target.Row, Target.Column)) <> "" And _
UCase(Cells(Target.Row, Target.Column)) <> "CANCELLED" Then
Cells.FormatConditions.Delete
End If
End If
ErrHandler:
'
End Sub
You don't "apply" and "remove". You "apply" in both cases, just that you apply different colours.
Private Sub Worksheet_Change(ByVal Target As Range)
Const TriggerClm As Long = 8 ' change to suit
Dim TriggerRng As Range
Dim TargetRng As Range
Dim IntCol As Long
' Here the first row is 2, presuming row 1 contains captions
Set TriggerRng = Range(Cells(2, TriggerClm), Cells(Rows.Count, TriggerClm).End(xlUp))
If Not Application.Intersect(Target, TriggerRng) Is Nothing Then
With Target
Set TargetRng = Range(Cells(.Row, TriggerClm - 7), Cells(.Row, TriggerClm))
If StrComp(CStr(.Value), "cancelled", vbTextCompare) Then
TargetRng.Interior.Pattern = xlNone
TargetRng.Font.Color = vbBlack
Else
TargetRng.Interior.Color = vbRed
TargetRng.Font.Color = vbWhite
End If
End With
End If
End Sub
Observe that I reasoned that a change can only be triggered if a cell in the 8th column is changed because only that cell is either "Cancelled" or not. My code's logic deviates from yours in this respect.
I am trying to solve an issue with a piece of code. I am aware this question has been asked before but i cannot get those solutions to work. The below worksheet change event does not trigger when i copy and paste data into column A but does when the user clicks into the cells manually how can i get round this?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Application.EnableEvents = False
For Each cell In Target
If Not Application.Intersect(cell, Range("A7:A1048576")) Is Nothing Then
If Not IsNumeric(cell.Value) Then
cell.Value = vbNullString
MsgBox ("Please re-enter, value entered contains non-numeric entry")
End If
End If
Next cell
If Not Intersect(Target, Range("A7:A1048576")) Is Nothing Then
On Error Resume Next
If Target.Value = "" Or Target.Value = "0" Then
Target.Offset(0, 12) = ""
Target.Offset(0, 13) = ""
Else
Target.Offset(0, 12).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
Target.Offset(0, 13).Value = Environ("username")
End If
End If
Application.EnableEvents = True
End Sub
This code should just about do what you want. Please try it.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
If Not Application.Intersect(Target, Range("A7:A1048576")) Is Nothing Then
Set Target = Target.Columns(1) ' remove all cells outside column A
Application.EnableEvents = False
For Each Cell In Target.Cells
With Cell
If .Value = "" Or .Value = 0 Then
.Offset(0, 12).Resize(1, 2).Value = vbNullString
Else
If Not IsNumeric(.Value) Then
.Value = vbNullString
MsgBox ("Please re-enter, value entered contains non-numeric entry")
.Select
Exit For
Else
.Offset(0, 12).Value = Format(Now, "mm/dd/yyyy HH:mm:ss")
.Offset(0, 13).Value = Environ("username")
End If
End If
End With
Next Cell
Application.EnableEvents = True
End If
End Sub
I'm using Worksheet_Change to make a value (either 1 or 0) appear in the next cell (Bx) when a value is entered in a range of cells (A1:A10).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else:
Target.Offset(0, 1).Value = 0
End If
End If
End Sub
The problem occurs when I try to clear the cells in column A.
When I select the cells I want to clear and press "Delete" I get "Run-time error '13' - Type mismatch" on the line "IF Target.Value = 1".
I would also like the cells in the B column to be cleared if I clear cells in the A column. E.g. if I delete cell A2:A5, B2:B5 should be cleared.
From what I understand the problem is that when selecting multiple cells it returns an array as the Target, and this is a mismatch with the Integer.
Is there a way around this problem?
Try this. You need to cater for multiple cells in some way, for the reasons you mention, and add an extra clause to your If.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, r1 As Range
Set r = Intersect(Target, Range("A1:A10"))
If Not r Is Nothing Then
For Each r1 In r
If r1.Value = 1 Then
r1.Offset(0, 1).Value = 1
ElseIf r1.Value = vbNullString Then
r1.Offset(0, 1).Value = vbNullString
Else
r1.Offset(0, 1).Value = 0
End If
Next r1
End If
End Sub
In a first step we add the functionality that multiple cells are selected and changed:
Private Sub Worksheet_Change_Var1(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Cells.Count > 1 Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
Next targetCell
Else
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else
Target.Offset(0, 1).Value = 0
End If
End If
End If
End Sub
In the 2nd step we understand that also the "one cell" case can be handled in the same way and we add an if clause for the "cell(s) cleared" case:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
'if cell in col A is empty, then clear cell in col B
If targetCell.Value = "" Then targetCell.Offset(0, 1).ClearContents
Next targetCell
End If
End Sub
I am having a problem of an infinite loop which is caused by the code below.
It is caused by changes in column E affecting changes in G and vice-versa constantly triggering Worksheet_Change(ByVal Target As Range)
In the below code I could stop this with a line that tests if the last change was made by the user or by VBA. Is there a way to test this condition?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E:E")) Is Nothing Then Macro
If Not Intersect(Target, Range("G:G")) Is Nothing Then Macro2
End Sub
Private Sub Macro()
Dim rng As Range
Dim i As Long
Set rng = Range("E1:E10")
For Each cell In rng
If cell.Value <> "" Then
If IsNumeric(cell.Value) Then
cell.Offset(0, 2).Value = cell.Value + cell.Offset(0, 1)
End If
Else
cell.Offset(0, 2).Value = 1
End If
Next
End Sub
Private Sub Macro2()
Dim rng As Range
Dim i As Long
Set rng = Range("G1:G10")
For Each cell In rng
If cell.Value <> "" Then
If IsNumeric(cell.Value) Then
cell.Offset(0, -2).Value = cell.Value - cell.Offset(0, -1)
End If
Else
cell.Offset(0, -2).Value = 1
End If
Next
End Sub
temporarily disable events triggering:
Private Sub Macro()
Dim rng As Range
Dim i As Long
Set rng = Range("E1:E10")
On Error GoTo HandleExit ' assure proper handling of any error
Application.EnableEvents = False 'disable events triggering
For Each cell In rng
If cell.Value <> "" Then
If IsNumeric(cell.Value) Then
cell.Offset(0, 2).Value = cell.Value + cell.Offset(0, 1)
End If
Else
cell.Offset(0, 2).Value = 1
End If
Next
HandleExit:
Application.EnableEvents = True 'enable back events triggering
End Sub
the same with Macro2
EDIT to add a possible refactoring of the code
BTW, your Sub Macro() could be rewritten with no loops and without relying on IsNumeric() function (which is not 100% reliable (e.g. IsNumeric("12.5.3") would return True)
Private Sub Macro()
On Error GoTo HandleExit ' assure proper handling of any error
Application.EnableEvents = False 'disable events triggering
With Range("E1:E10") 'reference your range
If WorksheetFunction.Count(.Cells) > 0 Then ' if any "truly" numeric values in referenced range
With .SpecialCells(xlCellTypeConstants, xlNumbers).Offset(, 2) ' reference referenced range cells with constant numeric content only
.FormulaR1C1 = "=sum(RC[-1]:RC[-2])" ' write needed formula
.Value = .Value ' get rid of the formula
End With
End If
If WorksheetFunction.CountBlank(.Cells) Then .SpecialCells(xlCellTypeBlanks).Offset(, 2).Value = 1 ' if any blank cell in referenced range then fill it with 1"
End With
HandleExit:
Application.EnableEvents = True 'enable back events triggering
End Sub
I have a code already but I want to know if this code can be altered or if there is a code that can check to see if a cell in the column E is empty and clear contents in a cell in column A if the someone exits the row
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
If Target.Value = vbEmpty Then
Cells(Target.Row, 1).ClearContents
End If
End If
End Sub
Edited as per DirkReichel suggestion
Add this formula in A1:
=IF(E1="","",IF(LEN(A1),A1,TODAY()))
Now drag it down in your column "A" as far as you need. It will add today's date in column "A" if there is a value in column "E". Otherwise column "A" will remain empty
You are trying to get information of the "last" selection upon a change.... but there isn't a build-in solution. With a global variable, you still can do like this:
Dim oldTarget As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If oldTarget Is Nothing Then GoTo e
If oldTarget.Rows.Count > 1 Then
Dim x As Range
For Each x In oldTarget.Rows
If x.Cells(1, 5).Value = "" Then x.Cells(1, 1).Value = ""
Next
Else
If oldTarget.Cells(1, 5).Value = "" Then oldTarget.Cells(1, 1).Value = ""
End If
e: Set oldTarget = Target.EntireRow
End Sub
As you see: Dim oldTarget As Range is outside of the sub. This way the set value/object stays until VBA get's stopped (closing the workbook / directly reset vba)
The first bit of your code checks for changes on column E to clear the column A.
So we just need to do the same thing again, but checking if column E is empty when changing column A.
This way, if you change the value on Column A and, at the same row, Column E is empty, it clears what you entered.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
If Target.Value = vbEmpty Then
Cells(Target.Row, 1).ClearContents
End If
Elseif Target.Column = 1 Then
If Cells(Target.Row, 5).Value = vbEmpty Then
Cells(Target.Row, 1).ClearContents
End If
End If
End Sub
Edit: So, after your comment, here is how you should use your code
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
If Target.Value = vbEmpty Then
Cells(Target.Row, 1).ClearContents
Else
'Insert here whatever code you got on the single click event (Except the sub and end sub)
End If
Elseif Target.Column = 1 Then
If Cells(Target.Row, 5).Value = vbEmpty Then
Cells(Target.Row, 1).ClearContents
End If
End If
End Sub