I am using a MsgBox in an if else condition. When I use other conditions along with MsgBox, the MsgBox pops up multiple times and I have to end the program.
Code in a module:
Sub CheckValue(Target)
If Target.Offset(0, 12) < 1 Then
MsgBox "This is a sample box"
Range(Target.Offset(0, -12), Cells(Target.MergeArea(1, 1).Row, Target.MergeArea(1, 1).Offset(1, -2).Column)).ClearContents
Target.Offset(0, 0).ClearContents
Target.Offset(-4, 0).Select
End If
I activate this sub through worksheet change:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$N$16" Then
Call CheckValue(Target)
End If
End Sub
As you clear contents in your CheckValue sub, you are triggering the change-event.
You have to add Application.EnableEvents
Sub CheckValue(Target)
If Target.Offset(0, 12) < 1 Then
MsgBox "This is a sample box"
Application.EnableEvents = false '--> disable event
Range(Target.Offset(0, -12), Cells(Target.MergeArea(1, 1).Row, Target.MergeArea(1, 1).Offset(1, -2).Column)).ClearContents
Target.Offset(0, 0).ClearContents
Application.EnableEvents = true '--> enable events
Target.Offset(-4, 0).Select
End If
end sub
Related
I require some help in combining two Worksheet_Change events. Event 1 will reformat the cell to the correct postcode format & event 2 will apply the proper function. How can i combine event 1 & 2 in order for both to work at the same time?
Any help would be greatly appreciated :)
Event 1
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("K17")) Is Nothing Then Exit Sub
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[A-Z]{1,2}[0-9]{1,2}\s[0-9][A-Z]{2}"
If Not .test(Cells(17, 11)) Then
Cells(17, 11) = UCase(Left(Cells(17, 11), Len(Cells(17, 11)) - 3) & " " & Right(Cells(17, 11), 3))
End If
End With
End Sub
Event 2
Private Sub Worksheet_Change2(ByVal Target As Range)
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("F7;K7")) Is Nothing Then
Application.EnableEvents = False
Target = StrConv(Target, vbProperCase)
Application.EnableEvents = True
End If
End Sub
Why not just split into two independent macros that each run during the Change event? The below might work. I'd be careful about doing .cells.count as that can be a lot if you delete an entire column or a wide range of data.
Private Sub Worksheet_Change(ByVal Target As Range)
Call macroFirst(Target)
Call macroSecond(Target)
End Sub
Private Sub macroFirst(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("K17")) Is Nothing Then Exit Sub
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[A-Z]{1,2}[0-9]{1,2}\s[0-9][A-Z]{2}"
If Not .test(Cells(17, 11)) Then
Cells(17, 11) = UCase(Left(Cells(17, 11), Len(Cells(17, 11)) - 3) & " " & Right(Cells(17, 11), 3))
End If
End With
End Sub
Private Sub macroSecond(ByVal Target As Range)
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("F7;K7")) Is Nothing Then
Application.EnableEvents = False
Target = StrConv(Target, vbProperCase)
Application.EnableEvents = True
End If
End Sub
I would like to create a sheet where I have rows that get a timestamp in the column next to it, if the content in the cell changes.
What do I do wrong in the following macro? The first macro works on its own, but not if I add several macros.
Sub Update01()
Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
With Target.Offset(0, 1)
.Value = Now
.NumberFormat = "MM/DD/YYYY hh:mm AM/PM"
End With
End Sub
Sub Update02()
If Target.Column <> 3 Then Exit Sub
If Target.Cells.Count > 3 Then Exit Sub
With Target.Offset(0, 3)
.Value = Now
.NumberFormat = "MM/DD/YYYY hh:mm AM/PM"
End With
End
Sub Main()
Call Update01
Call Update02
End Sub
You probably meant to do something like the following
Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
On Error Goto ENABLE_EVENTS
Application.EnableEvents = False
If Target.Column = 1 Then
With Target.Offset(0, 1)
.Value = Now
.NumberFormat = "MM/DD/YYYY hh:mm AM/PM"
End With
ElseIf Target.Column = 3
With Target.Offset(0, 3)
.Value = Now
.NumberFormat = "MM/DD/YYYY hh:mm AM/PM"
End With
End If
ENABLE_EVENTS:
Application.EnableEvents = True
End Sub
Note that you need to Application.EnableEvents = False before writing a value to a cell otherwise this would trigger the Worksheet_Change over and over again.
Also note that Worksheet_Change is an event. That means it runs automatically whenever a cell value in the worksheet gets changed. You cannot run this procedure manually and you cannot Call it.
Requirement - compare two rows , if found duplicate row ,display popup of "duplicate rows" and wouldn't proceed to next cell.. this code is not working as it is comparing column.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, j As Long
If Not Intersect(Target, Columns("G:L")) Is Nothing Then
If Target.Value <> "" Then
lastRow = Cells(Rows.Count, Target.Column).End(xlUp).Row
For j = 1 To lastRow
If Cells(j, Target.Column).Value = Target.Value And j <> Target.Row Then
MsgBox "row having same value"
Target.Clear: Target.Select
Exit For
End If
Next j
End If
End If
End Sub
You don't have to loop. You can use the excel function CountIf
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Columns("G:L")) Is Nothing Then
If Target.Value <> "" Then
If Application.WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
MsgBox "Row Having Same Value"
Application.EnableEvents = False
Target.ClearContents: Target.Select
Application.EnableEvents = True
End If
End If
End If
End Sub
I am using this code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = True
On Error GoTo Errormask
With Target
If .Column = 30 And .Row > 16 And .Value = "Remove" Then
.EntireRow.Delete
Target.Offset(, 2).Select
End If
End With
Errormask:
Application.DisplayAlerts = False
Exit Sub
End Sub
If a user clicks on the cell in column 30 which contains "remove", it should delete the row and then select the cell 1 across.
This is not working. Please can someone show me where i am going wrong?
In your with, do the offset on the line below before deleting the entire row.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Target.CurrentRegion.Count = 1 And Target.Cells.Count = 1 Then
If .Column = 30 And .Row > 16 And .Value Like "Remove" Then
.Offset(1, 2).Select
.EntireRow.Delete
End If
End If
End With
Application.DisplayAlerts = False
End Sub
Are you sure you have this in the code of your sheet and not in a module?
EDIT
I have added a new If to check the select cell isn't merged first, and only a single cell is selected.
Try the code below:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = True
On Error GoTo Errormask '<-- don't see the need for this line
With Target
If .Column = 30 And .Row > 16 And .Value Like "Remove" Then
.EntireRow.Delete
.Offset(, 2).Select
End If
End With
Errormask: '<-- don't see the need for this line
Application.DisplayAlerts = False
Exit Sub '<-- don't see the need for this line, anyway at the end of the Sub
End Sub
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