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
Related
I need help with Excel VBA code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
If the third column we enter -1 it will clear the row. If we enter 1000 it will be copied to another sheet and deleted from the current sheet.
The above code is working fine. Instead of clearing row data, I want to delete that row.
So added
Line 4 With Target.EntireRow.ClearContents to With Target.EntireRow.Delete
But it shows an error.
It would help to know what error you get. Assuming the error is caused because the Week Schedule sheet does not exist, you can add a check for that. After that, your code works fine:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
SheetExistsOrCreate ("Week Schedule")
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
Function SheetExistsOrCreate(name As Variant)
For i = 1 To Worksheets.Count
If Worksheets(i).name = "MySheet" Then
exists = True
End If
Next i
If Not exists Then
Worksheets.Add.name = name
End If
End Function
Please, try the next adapted code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If LCase(Target.Value) = -1 Then
Target.EntireRow.Delete
ElseIf Target.Value = 1000 Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
Application.EnableEvents = True
End If
End Sub
The above code assumes that the Target value means a number, not a string looking as a number. If a string, you can place them between double quotes, as in your initial code.
Of course, a sheet named "Week Schedule" must exist in the active workbook and must not be protected.
I need to copy the contents of a cell in a particular column to another corresponding column on change so the old value is moved. Only wants to work for a particular column.
Private sub Worksheet_Change(ByVal Target As Range)
if Target.Range("L:L") then
'set I cell value = to original L cell value
ActiveCell.Offset(0,-3).Value = ActiveCell.Value
End If
End Sub
This code should do what you want. Please take note of the comments which explain some limitations I have imposed on the action of this procedure. The rule to follow is to not give it more power than it needs to do the job you want it to do.
Private Sub Worksheet_Change(ByVal Target As Range)
' 027
Dim Rng As Range
' don't react if the changed cell is in row 1 or
' if it is more than 1 row below the end of column L
Set Rng = Range(Cells(2, "L"), Cells(Rows.Count, "L").End(xlUp).Offset(1))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
' skip if more than 1 cell was changed
' meaning, exclude paste actions
If .Cells.CountLarge = 1 Then
.Offset(0, -3).Value = .Value
End If
End With
End If
End Sub
This will save the previous value in column I:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant
If Target.Count > 1 Then Exit Sub
If Intersect(Range("L:L"), Target) Is Nothing Then Exit Sub
With Application
v = Target.Value
.EnableEvents = False
.Undo
Target.Offset(0, -3).Value = Target.Value
Target.Value = v
.EnableEvents = True
End With
End Sub
EDIT#1:
To update L without triggering the event, use something like:
Sub ScriptThatUpdatesColumn_L()
Application.EnableEvents = False
Range("L5").Value = "just me"
Application.EnableEvents = True
End Sub
So I am trying to find a solution where i can copy paste multiple values from one column into another column and have it leave out duplicates already existing.
I found this code but it only works if I copy paste one value at a time.
Is there a way to make it work so it will paste in unique copied values only, that does not exist in the column already?
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
''''''''''''''''''''''''''''''''''''''''''
'Prevents duplicate entries in Column A
''''''''''''''''''''''''''''''''''''''''''
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 1 And Target <> vbNullString Then 'Column A
If WorksheetFunction.CountIf(Columns(1), Target) > 1 Then
MsgBox "Entry " & Target & " already exists!", _
vbCritical, "Dixons Travel Oslo"
Target = ""
Target.Select
End If
End If
End Sub
Maybe you find this usefull:
Below code assumes you just copy in all the values, even if they exist allready.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Range("A1", Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End If
End Sub
It will look like this:
Change Header:=xlNo to Header:=xlYes if that applies to your situation.
Obviously, there are other ways. I just find this quite easy.
Using a similar methodology to your existing one, you could do the following:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.EnableEvents = False
For Each tcell In Target.Cells
With tcell
If .Column = 1 And .Value <> vbNullString Then 'Column A
If WorksheetFunction.CountIf(Columns(1), .Value) > 1 Then
tcell.Value = ""
End If
End If
End With
Next
Application.EnableEvents = True
End Sub
Here's another way - expanding and improving on JvdV's idea:
Private Sub Worksheet_Change(ByVal Target As Range)
With Target.Parent
If Not (Intersect(Target, .Columns(1)) Is Nothing) Then
Range("A1", Range("A" & .Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
End If
End With
End Sub
This allows for multiple cells to be pasted - regardless of how many columns are affected and de-dupes the whole of column A.
You could try:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 1 Then
Application.EnableEvents = False
ThisWorkbook.Worksheets("Sheet1").Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Application.EnableEvents = True
End If
End Sub
Notes:
You could change sheet name
Header option
There's a lot I like about this script I use to auto-insert the date into next cell over from where I input a value, but I would like if it didn't change a date that already existed.
When I input the initials of whoever finished a job into a cell in range T3:T5003, the date is automatically inserted in the adjacent cell in range U3:U5003. The problem is that I might have to change or modify the entries in T3:T5003 at a later date, but I don't want the original date to change. So I just want this auto-inserting to work only when there is nothing in the adjacent cell.
Here's the code I am using:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("T3:T5003"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).Activate
Else
With .Offset(0, 1)
.Value = Date
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
I've tried other scripts that didn't write over an existing date, but they had other problems, and they were difficult for me to understand how they work, so I'm hoping that we can just modify the one I'm using. But I will take anything that works and I really appreciate your help.
I think you just need to an IF checking if the cell to the right is empty or not:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("A1:A100"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).Activate
Else
If .Offset(0, 1).Value2 = "" Then
With .Offset(0, 1)
.Value = Date
End With
End If
End If
Application.EnableEvents = True
End If
End With
End Sub
This should do
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("T3:T5003"), .Cells) Is Nothing Then
If IsEmpty(.Offset(0, 1)) Then .Offset(0, 1).Value = Date
End If
End With
End Sub
I have code that retrieves information from SQL and VFP and populates a dropdown list in every cell in column "A" except A1 - this is a header.
I need to populate the "G" column on the row where the user selects the value from a dropdown in the "A" column.
I believe I need to be in Private Sub Worksheet_SelectionChange(ByVal Target As Range) which is in the sheet object.
Below is something similar to what I want to do.
If cell "a2".valuechanged then
Set "g2" = "8000"
End if
If cell "a3".valueChanged then
Set "g3" = "8000"
End if
The code above doesn't work, but I think it is easy to understand. I want to make this dynamic, so I don't have too many lines of code.
I have already explained about events and other things that you need to take care when working with Worksheet_Change HERE
You need to use Intersect with Worksheet_Change to check which cell the user made changes to.
Is this what you are trying?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
'~~> Check if the user made any changes in Col A
If Not Intersect(Target, Columns(1)) Is Nothing Then
'~~> Ensure it is not in row 1
If Target.Row > 1 Then
'~~> Write to relevant cell in Col G
Range("G" & Target.Row).Value = 8000
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Try this
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column <> 7 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
If you only need it to fire on column A then
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column = 1 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
can you not put an if statement in column G , as in
If (A1<>"", 8000,0)
Other wise something like this will get you going:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Value2 <> "" Then
Target.Offset(0, 6) = "8000"
Else
Target.Offset(0, 6) = ""
End If
End If
On Error GoTo 0
End Sub
Thanks
Ross
I had a similar problem. I used Siddharth Rout's code. My modifications allow a user to paste a range of cells in column a (ex. A3:A6) and have multiple cells modified (ex. H3:H6).
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge < 1 Then Exit Sub
If Target.Cells.CountLarge > 500 Then Exit Sub
Debug.Print CStr(Target.Cells.CountLarge)
Application.EnableEvents = False
Dim the_row As Range
Dim the_range As Range
Set the_range = Target
'~~> Check if the user made any changes in Col A
If Not Intersect(the_range, Columns(1)) Is Nothing Then
For Each the_row In the_range.Rows
'~~> Ensure it is not in row 2
If the_row.Row > 2 Then
'~~> Write to relevant cell in Col H
Range("H" & the_row.Row).Value = Now
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub