I know that you can have only one private sub worksheet change event however I am struggling to combine code for the events I need. I am new to VBA so any assistance or recommendations are appreciated. Would it be more efficient to use select case?
First code needed:
Private Sub Worksheet_Change(ByVal target As Range)
Dim cell As Range
Set cell = Range("AK9:AR50")
Application.EnableEvents = False
If Not Application.Intersect(cell, target) Is Nothing Then
If target.Column = 37 Then
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
ElseIf target.Column = 38 Then
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
End If
If target.Column = 39 Then
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
ElseIf target.Column = 40 Then
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
End If
If target.Column = 41 Then
target.Offset(, 1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
ElseIf target.Column = 42 Then
target.Offset(, -1).Value = target.Value / Range("V" & target.Row).Value
End If
If target.Column = 43 Then
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
ElseIf target.Column = 44 Then
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
End If
End If
Application.EnableEvents = True
End Sub
Second code needed:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim controlRng, nRng As Range
Set controlRng = Range("AF9:AF1000")
Set nRng = Intersect(controlRng, Target)
If nRng Is Nothing Then Exit Sub
If Target.Value = "No Promotion" Then
Target.Offset(0, 1) = Range("M" & Target.Row).Value
ElseIf Target.Value = "Promotion" Then
Target.Offset(0, 1) = ""
ElseIf Target.Value = "Demotion" Then
Target.Offset(0, 1) = ""
ElseIf Target.Value = "Partner" Then
Target.Offset(0, 1) = ""
ElseIf Target.Value = "" Then
Target.Offset(0, 1) = ""
End If
End Sub
Select Case will certainly tidy up your code. You might also want to build in a check that Target is not more than a single cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim controlRng As Range, nRng As Range
Set cell = Range("AK9:AR50")
Set controlRng = Range("AF9:AF1000")
Set nRng = Intersect(controlRng, Target)
Application.EnableEvents = False
If Not Application.Intersect(cell, Target) Is Nothing Then
Select Case Target.Column
Case 37, 39, 41, 43
Target.Offset(, 1).Value = Target.Value / Range("V" & Target.Row).Value
Case 38, 40, 42, 44
Target.Offset(, -1).Value = WorksheetFunction.RoundUp((Target.Value * Range("V" & Target.Row).Value), -2)
End Select
End If
If Not nRng Is Nothing Then
Select Case Target.Value
Case "No Promotion"
Target.Offset(0, 1) = Range("M" & Target.Row).Value
Case "Promotion", "Demotion", "Partner", ""
Target.Offset(0, 1).ClearContents
End Select
End If
Application.EnableEvents = True
End Sub
Related
I have this simple bit of code that automates some dates and stuff when adding line items to a sheet. It works well, but when I insert a line in to the spreadsheet [right-click the line name > insert] an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim plusWeek
plusWeek = Now() + 7
For Each cell In Target
'========adds closed date, deleted date if status degenerates=========
If cell.Column = 13 And cell = "Closed" Then
Target.Offset(0, -2) = Format(Now(), "yyyy-mm-dd")
End If
If cell.Column = 13 And cell = "In-Progress" Then
Target.Offset(0, -2) = ""
End If
If cell.Column = 13 And cell = "Open" Then
Target.Offset(0, -2) = ""
End If
'========adds date added if date is embty and description is not empty========
If cell.Column = 8 And IsEmpty(Target.Offset(0, 1)) And Not IsEmpty(Target.Offset(0, 0)) Then
Target.Offset(0, 1) = Format(Now(), "yyyy-mm-dd")
Target.Offset(0, 2) = Format(plusWeek, "yyyy-mm-dd")
Target.Offset(0, 5) = "Open"
End If
'========deletes date added if description is empty========
'If cell.Column = 8 And IsEmpty(Target.Offset(0, 0)) Then
' Target.Offset(0, 1) = ""
'End If
Next cell
End Sub
if I paste a line, add a line or delete a line, error 1004 occurs. The debugger highlights this line, but I can't understand where the error comes from.
If cell.Column = 8 And IsEmpty(Target.Offset(0, 1)) And Not
IsEmpty(Target.Offset(0, 0)) Then
Something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, rng As Range
Dim plusWeek
plusWeek = Now() + 7
Set rng = Application.Intersect(Target, Me.Range("H:H,M:M"))
If rng Is Nothing Then Exit Sub
On Error GoTo haveError '<< make sure events don't get left turned off
Application.EnableEvents = False '<< turn events off
For Each cell In rng.Cells
'========adds closed date, deleted date if status degenerates=========
If cell.Column = 13 Then
Select Case cell.Value
Case "Closed": cell.Offset(0, -2) = Format(Now(), "yyyy-mm-dd")
Case "In-Progress", "Open": cell.Offset(0, -2) = ""
End Select
End If
'========adds date added if date is embty and description is not empty========
If cell.Column = 8 And IsEmpty(cell.Offset(0, 1)) And Not IsEmpty(cell) Then
cell.Offset(0, 1) = Format(Now(), "yyyy-mm-dd")
cell.Offset(0, 2) = Format(plusWeek, "yyyy-mm-dd")
cell.Offset(0, 5) = "Open"
End If
'========deletes date added if description is empty========
'If cell.Column = 8 And IsEmpty(Target.Offset(0, 0)) Then
' Target.Offset(0, 1) = ""
'End If
Next cell
haveError:
Application.EnableEvents = True
End Sub
Hi I am having a excel file. There is a macro in the excel file to clear the dependent drop down list . When we copy the value from one row to another row or one column to another column we are getting run time error 13. Could you please help us to resolve the issue
Code :
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 2 And Target.Row < 100 Then
If Target.Column = 2 And Target.Cells.Count = 1 And Target.Value = "Create Account_Personal" Then
Target.Offset(0, 3).Value = "NA"
Target.Offset(0, 4).Value = "NA"
Target.Offset(0, 5).Value = "NA"
Target.Offset(0, 6).Value = "NA"
Target.Offset(0, 7).Value = "NA"
Target.Offset(0, 8).Value = "NA"
Target.Offset(0, 9).Value = "NA"
Target.Offset(0, 10).Value = "NA"
Target.Offset(0, 11).Value = "NA"
Target.Offset(0, 19).Value = "NO"
Target.Offset(0, 22).Value = "NO THANKS"
ElseIf Target.Column = 2 And Target.Cells.Count = 1 And Target.Value <> "Create Account_Personal" Then
Target.Offset(0, 3).Value = "Select Country"
End If
If Target.Column = 5 And Target.Cells.Count = 1 And Target.Value <> "NA" Then
Target.Offset(0, 1).Value = "select State"
Target.Offset(0, 2).Value = ""
Target.Offset(0, 3).Value = ""
Target.Offset(0, 4).Value = ""
Target.Offset(0, 5).Value = ""
Target.Offset(0, 6).Value = ""
Target.Offset(0, 7).Value = ""
Target.Offset(0, 9).Value = ""
Target.Offset(0, 10).Value = ""
Target.Offset(0, 11).Value = ""
Target.Offset(0, 12).Value = ""
Target.Offset(0, 13).Value = ""
Target.Offset(0, 14).Value = ""
Target.Offset(0, 15).Value = ""
End If
End If
End Sub`enter code here`
Disable events by using Application.EnableEvents = False
For consecutive cells use …
Target.Parent.Range(Target.Offset(0, 3), Target.Offset(0, 11)).Value = "NA"
… to write NA between column 3 and 11. Which is much shorter and faster.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo ENABLE_EVENTS
If Target.Row > 2 And Target.Row < 100 Then
If Target.Column = 2 And Target.Cells.Count = 1 Then
If Target.Value = "Create Account_Personal" Then
Target.Parent.Range(Target.Offset(0, 3), Target.Offset(0, 11)).Value = "NA"
Target.Offset(0, 19).Value = "NO"
Target.Offset(0, 22).Value = "NO THANKS"
ElseIf Target.Value <> "Create Account_Personal" Then
Target.Offset(0, 3).Value = "Select Country"
End If
End If
If Target.Column = 5 And Target.Cells.Count = 1 Then
If Target.Value <> "NA" Then
Target.Offset(0, 1).Value = "select State"
Target.Parent.Range(Target.Offset(0, 2), Target.Offset(0, 7)).Value = ""
Target.Parent.Range(Target.Offset(0, 9), Target.Offset(0, 15)).Value = ""
End If
End If
End If
ENABLE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
I have created a macro to update certain values and after these values are entered they are used to create a text file for import into our system.
Below is a screen shot of the data entry screen:
Below is the code, I have written on the worksheet:
Option Explicit
Public Rec_Cnt As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Rec_Cnt = Sheets("MD").Cells(3, 7)
Set Rng1 = Range("G2:G" & Rec_Cnt + 1)
Set Rng2 = Range("M2:M" & Rec_Cnt + 1)
Set Rng3 = Range("S2:S" & Rec_Cnt + 1)
Set Rng4 = Range("D2:E" & Rec_Cnt + 1)
If Not Application.Intersect(Target, Rng1) Is Nothing Then
If Len(Target) > 10 Then
Call Original_Ticket_Greater_Error
ElseIf Len(Target) < 10 Then
Call Original_Ticket_Lesser_Error
ElseIf Len(Target) = 10 Then
Cells(Target.Row, 8).Value = 9
Cells(Target.Row, 9).Value = "|"
Cells(Target.Row, 10).Value = "|"
Cells(Target.Row, 11).Value = "|"
Cells(Target.Row, 12).Value = "|"
Exit Sub
End If
ElseIf Not Application.Intersect(Target, Rng2) Is Nothing Then
If Len(Target) > 10 Then
Call Original_Cnj_Ticket_Greater_Error
ElseIf Len(Target) < 10 Then
Call Original_Cnj_Ticket_Lesser_Error
ElseIf Len(Target) = 10 Then
Cells(Target.Row, 14).Value = 9
Cells(Target.Row, 15).Value = "|"
Cells(Target.Row, 16).Value = "|"
Cells(Target.Row, 17).Value = "|"
Cells(Target.Row, 18).Value = "|"
Exit Sub
End If
ElseIf Not Application.Intersect(Target, Rng3) Is Nothing Then
If Len(Target) > 10 Then
Call Original_Ticket_Greater_Error
Exit Sub
ElseIf Len(Target) < 10 Then
Call Original_Ticket_Lesser_Error
Exit Sub
End If
ElseIf Not Application.Intersect(Target, Rng4) Is Nothing Then
If Cells(Target.Row, 3).Value = "Sales" Or Cells(Target.Row, 3).Value = "Sales Conjunction" Then
Cells(Target.Row, 6).Value = Application.Sum((Cells(Target.Row, 4).Value), (Cells(Target.Row, 5).Value))
Cells(Target.Row, 6).Value = Int(Cells(Target.Row, 6).Value * 100)
End If
End If
End Sub
Sub Original_Ticket_Greater_Error()
MsgBox "Original Ticket Number is more than 10 characters"
End Sub
Sub Original_Cnj_Ticket_Greater_Error()
MsgBox "Original Conj. Ticket Number is more than 10 characters"
End Sub
Sub Original_Ticket_Lesser_Error()
MsgBox "Original Ticket Number is less than 10 characters"
End Sub
Sub Original_Cnj_Ticket_Lesser_Error()
MsgBox "Original Conj. Ticket Number is less than 10 characters"
End Sub
Based on the code you can notice that I am updating certain cells only when the Target = 10 and otherwise not.
I wanted to change the font to RED when the Target is >10 or <10 and have tried couple of options but the font color doesn't change.
I have used Target.Font.Color and similar options.
Any help is much appreciated.
Thanks,
Sachin
You can achieve this with some conditional formatting.
From the Home ribbon click on Conditional Formatting and Manage Rules. Then select New Rule.
In the formula textbox, enter =INDIRECT("G"&ROW())<>10
In the applies to textbox, enter the column minus the header =$G$2:$G$1048576
Example Results:
I am trying to create a VBA code on a Excel sheet where I can automatically insert the created date (once data is being inserted in a row) and updated date (once any cell value of the row change from the previous value).
I tried the code below, I can get the created date but the not the update date.
I get this error
Type mismatch
on the line:
If Cells(Target.Row, i).Value <> PrevVal(Target.Row, i) Then
I guess the problem is that I don't know how to capture properly the previous value of a cell in order to compare it with the new value.
For reference: my table is like this:
Id Position1 Position2 DATE Created Date updated Data1 Data2 ....
Dim PrevVal As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGraceFully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Selection.Value
Else
PrevVal = Selection
End If
ExitGraceFully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("B:B"), Target) Is Nothing Or Not
Intersect(Range("C:C"), Target) Is Nothing Then
Cells(Target.Row, 1).Value = Cells(Target.Row, 2) & Cells(Target.Row, 3)
If Cells(Target.Row, 4).Value = "" Then
Cells(Target.Row, 4).Value = Date & " " & Time
Cells(Target.Row, 4).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If
Dim i As Integer
If Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
For i = 2 To 50
If Cells(Target.Row, i).Value <> PrevVal(Target.Row, i) Then
Cells(Target.Row, 5).Value = Date & " " & Time
Cells(Target.Row, 5).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next i
End If
End Sub
I finally corrected my code and now it's working well.
Dim PrevVal As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGraceFully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Target.Value
Else
PrevVal = Target
End If
ExitGraceFully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("B:C"), Target) Is Nothing Then
Cells(Target.Row, 1).Value = Cells(Target.Row, 2) & Cells(Target.Row, 3)
If Cells(Target.Row, 4).Value = "" Then
Cells(Target.Row, 4).Value = Date & " " & Time
Cells(Target.Row, 4).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If
If Not Intersect(Range("F:Z"), Target) Is Nothing Then
Application.EnableEvents = False
If (PrevVal <> "") And (Cells(Target.Row, Target.Column).Value <> PrevVal) Then
Cells(Target.Row, 5).Value = Date & " " & Time
Cells(Target.Row, 5).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If
Application.EnableEvents = True
End Sub
Thank you so much #userZZZ, this is exactly what I was looking for!
I adapted your code to my requirements and added another constraint to change the date also when the content of a cell is deleted. I noticed that the code only works for single cells, but not for multiple cells. I might work on that sometime, but for now this is sufficient.
Edit: I added the possibility to manipulate multiple cells at once and update the date for all the corresponding rows. It still doesn't work for copy/paste of multiple cells though. For that purpose, I added an error message. Alternatively, the copy/paste mode can simply be deactivated by adding "Application.CutCopyMode = False" right at the beginning of the first function.
Dim PrevVal As Variant
Dim Block_rows As Integer
Dim Date_column As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo ExitGracefully
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
PrevVal = Target.Value
Else
PrevVal = Target
End If
ExitGracefully:
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Date_column = 9
Block_rows = 8
On Error GoTo ErrorMessage
'Select and change single cell
If Not Intersect(Range("A:H"), Target) Is Nothing And Target.Row > Block_rows Then
Application.EnableEvents = False
If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
'Update date if value changes or is deleted
If (Cells(Target.Row, Target.Column).Value <> PrevVal) Or _
(Cells(Target.Row, Target.Column).Value = 0 And PrevVal <> 0) Then
Cells(Target.Row, Date_column).Value = Date
Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"
End If
'Select multiple cells, but only change single cells
ElseIf (Cells(Target.Row, Target.Column).Value <> PrevVal(Target.Row - Selection.Row + 1, Target.Column - Selection.Column + 1)) And _
(Cells(Target.Row, Target.Column).Value <> 0) Then
Cells(Target.Row, Date_column).Value = Date
Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"
'Delete multiple cells at once
Else
For RCount = 0 To Target.Rows.Count - 1
For CCount = 0 To Target.Columns.Count - 1
'Blank rows
If (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) = 0) Then
'Delete cells or rows
ElseIf (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) <> 0) Then
Cells(Target.Row + RCount, Date_column).Value = Date
Cells(Target.Row + RCount, Date_column).NumberFormat = "dd-mmm-yyyy"
End If
Next CCount
Next RCount
End If
End If
Application.EnableEvents = True
Exit Sub
ErrorMessage:
MsgBox ("This function is not supported for the automatic update of the date.")
Resume Next
End Sub
I have the following code below. Instead of using stagnant ranges (i.e., Range("AF9:AF50") & Range(AK9:BI50")) I'm looking to implement a dynamic range that runs the code starting at row 9 through the last row of data for those columns. I've been reading on how to set dynamic ranges but I can't get it to work. Any advice/assistance is greatly appreciated.
Private Sub Worksheet_Change(ByVal target As Range)
Dim cell As Range
Dim controlRng As Range, nRng As Range
Set cell = Range("AK9:BI50")
Set controlRng = Range("AF9:AF50")
Set nRng = Intersect(controlRng, target)
Application.EnableEvents = False
If Not nRng Is Nothing Then
Select Case target.Value
Case "No Promotion"
target.Offset(, 1).Value = Range("M" & target.Row).Value
target.Offset(, 4).Value = Range("P" & target.Row).Value
target.Offset(, 9).Value = ""
Case "Promotion"
target.Offset(, 1).Value = ""
target.Offset(, 4).Value = ""
target.Offset(, 9).Value = 0.07
Case "Demotion", "Partner", ""
target.Offset(, 1).Value = ""
target.Offset(, 4).Value = ""
target.Offset(, 9).Value = ""
End Select
End If
If Not Application.Intersect(cell, target) Is Nothing Then
Select Case target.Column
Case 37, 39, 43
target.Offset(, 1).Value = target.Value / Range("V" & target.Row).Value
Case 38, 40, 44
target.Offset(, -1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
Case 41, 60
target.Offset(, 1).Value = WorksheetFunction.RoundUp((target.Value * Range("V" & target.Row).Value), -2)
Case 42, 61
target.Offset(, -1).Value = target.Value / Range("V" & target.Row).Value
End Select
End If
Application.EnableEvents = True
End Sub
I'm assuming your problem is dealing with the letter aspect of ranges and trying to make that dynamic? If so the syntax you may be looking for is.
Set MyRange = MySheet.Range(MySheet.Cells(TopRow, LeftCol), MySheet.Cells(LastRow, RightCol))
So For example, these two ranges will be equivalent but the first can be generated dynamically.
TopRow = 1
LeftCol = 2
LastRow = 100
RightCol = 3
Set MyRange = MySheet.Range(MySheet.Cells(TopRow, LeftCol), MySheet.Cells(LastRow, RightCol))
Set MyOtherRange = mysheet.range("B1:C100")
There are several methods to find the last row of a column, some work better in other circumstances then others. Look here https://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba
I usually use this
LastRow = sht.Cells(sht.Rows.Count, ColumnNumber).End(xlUp).Row
If I understand the question correctly, the columns and starting rows are static and only a dynamic last row reference is needed.
In Worksheet_Change event:
Set cell = Range("AK9:" & LastRow("BI"))
Set controlRng = Range("AF9:" & LastRow("AF"))
Choose a row number larger than any number of rows your data will likely have (e.g.1000). Then, in the same module:
function LastRow(strColumn as string) as long
LastRow=range(strColumn & 1000).end(xlup).row
end function
VBA will re-calculate the LastRow every time the Worksheet_Change event is raised,
thus making your ranges dynamic.