Delete entire based on another cell value - excel

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.

Related

How to repeat this function in VBA?

I have this function now in Excel VBA:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Address = Cells(1, 5).Address Then
Cells(1, 6) = Application.UserName
Cells(1, 7) = Now
Else
Debug.Print "This was not B1"
End If
End Sub
this works perfect for one cell on one line. Now I need to have it for multiple lines on this sheet. How do I do that? When just copying and updating the parameters in the Cells lines I get the error message that the eventname cannot be used twice.
Final solution for me would be that for all 15 lines on in this sheet I have this function.
You can only have one SelectionChange event per worksheet, so you need to handle everything in that event.
If you want to do different things use:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
If Target.Address = Cells(1, 5).Address Then
Cells(1, 6) = Application.UserName
Cells(1, 7) = Now
ElseIf Target.Address = … your other cell address … Then
'do something else
Else
Debug.Print "This was not B1"
End If
End Sub
If you want to do the same thing for multiple lines the do the following:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
If Not Intersect(Target, Me.Range(Me.Cells(1, 5), Me.Cells(10, 5))) Is Nothing Then
Target.Offset(ColumnOffset:=1) = Application.UserName
Target.Offset(ColumnOffset:=2) = Now
Else
Debug.Print "This was not B1"
End If
End Sub
This will work from row 1 Me.Cells(1, 5) to row 10 Me.Cells(10, 5) and will write the username to column 6 and time to column 7 of the selected row of column 5 in that range.

Add 2 private subs to 1 worksheet?

Hi how can i add both of these codes to 1 worksheet ?
The code auto copies data from 1 sheet to another
Thanks
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "y" Then
With Target.EntireRow
.Copy
Sheets("sheet9").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues
End With
Application.CutCopyMode = False
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "b" Then
With Target.EntireRow
.Copy
Sheets("sheet10").Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues
End With
Application.CutCopyMode = False
End If
End If
End Sub
Your two subs do essentially the same thing, so you only need one:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As string
If Target.Column = 2 And Target.Cells.Count = 1 Then
Select Case LCase(Target.Value)
Case "y": ws = "Sheet9"
Case "b": ws = "Sheet10"
End select
If ws <> "" Then
Thisworkbook.sheets(ws).cells(rows.count,1).end(xlUp).offset(1,0).Entirerow.value = _
Target.EntireRow.Value
End If
End If
End Sub

VBA Worksheet_Change Only Working For One Cell

I'd like to preface by saying I am a novice to VBA, so hopefully this is an easy fix.
I am trying to get the following VBA code to work for multiple cells with formulas. The effect is that there is a ghost value in the cell a user can overwrite then see again if they delete their value. I can get one cell to work how I want it to, but the second (and third and fourth etc.) do not work. How can I repeat this same line of code so that the effect repeats itself in multiple cells with different formulas?
Working:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F7" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
My attempt (Top working, bottom not):
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F7" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
Private Sub Worksheet_Change1(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F8" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
Try this...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, v, t
v = Target.Value2
If Not IsArray(v) Then t = v: ReDim v(1 To 1, 1 To 1): v(1, 1) = t
Application.EnableEvents = False
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
If Len(v(i, j)) = 0 Then
With Target(i, j)
Select Case .Address(0, 0)
Case "A1": .Formula = "=""Excel"""
Case "A2": .Formula = "=""Hero"""
End Select
End With
End If
Next
Next
Application.EnableEvents = True
End Sub
Use your formulas and ranges instead of mine, of course.
Update
The above works well, but this is faster/better...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, v
DoEvents
ReDim v(1 To 3, 1 To 2)
v(1, 1) = "A1": v(1, 2) = "=""This"""
v(2, 1) = "A2": v(2, 2) = "=""Works"""
v(3, 1) = "A2": v(3, 2) = "=""Great!"""
Application.EnableEvents = False
For i = 1 To UBound(v)
With Range(v(i, 1))
If Not Intersect(Target, .Cells) Is Nothing Then
If Len(.Value2) = 0 Then
.Formula = v(i, 2)
End If
End If
End With
Next
Application.EnableEvents = True
End Sub
Both of the above methods work for single-cell deletes AND also for clearing and deleting large ranges, including whole columns and whole rows and the second method is particularly quick in all these scenarios.
You can do something like this:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'only handle single cells
If Target.Cells.CountLarge > 1 Then Exit Sub
If IsError(Target.Value) Then Exit Sub '<< edit: added
'only handle empty cells
If Len(Target.Value) > 0 Or Len(Target.Formula) > 0 Then Exit Sub
On Error Goto haveError
Application.EnableEvents = False
Select Case Target.Address(False, False)
Case "F7": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Case "F8": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
End Select
haveError:
'ensure events are re-enabled
Application.EnableEvents = True
End Sub

Excel VBA script looping not working fine

When B21 is blank and I click on D21 cell, I get shown error 2 and error 1(this is not expected as I am expecting only error 1). But when I click on E21 cell I get shown only Error 2 which is expected.
I am not sure where am I going wrong ?
My code is below:
If [B21] = "" Then
If Target.Column = 4 Then
If Target.Row = 21 Then
Beep
Cells(Target.Row, Target.Column).Offset(0, 1).Select
MsgBox "1.Error"
End If
ElseIf Target.Column = 5 Then
If Target.Row = 21 Then
Beep
Cells(Target.Row, Target.Column).Offset(0, 1).Select
MsgBox "2.Error"
End If
End If
When your code selects a cell, that also triggers the event handler. Typically you would prevent that by setting Application.EnableEvents = False (don't forget to set it back to True later...) –
an alternative to Tim Williams's solution is a worksheet scoped variable to keep track of when E21 cell is being selected by your code itself
so your worksheet code would be:
Dim dontBeep As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If [B21] = "" Then
If Target.Column = 4 Then
If Target.Row = 21 Then
Beep
dontBeep = True ' make sure subsequent E21 cell selection would not trigger any beep and action
Target.Offset(0, 1).Select
MsgBox "1.Error"
End If
ElseIf Target.Column = 5 Then
If Target.Row = 21 Then
If dontBeep Then
dontBeep = False ' restore default triggering conditions
Else
Beep
Target.Offset(0, 1).Select
MsgBox "2.Error"
End If
End If
End If
End If
End Sub
you could also take row index check at the beginning, since it's the same for both relevant columns:
Dim dontBeep As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If [B21] = "" Then
If Target.Row = 21 Then
If Target.Column = 4 Then
Beep
dontBeep = True ' make sure subsequent E21 cell selection would not trigger any beep and action
Target.Offset(0, 1).Select
MsgBox "1.Error"
ElseIf Target.Column = 5 Then
If dontBeep Then
dontBeep = False
Else
Beep' restore default triggering conditions
Target.Offset(0, 1).Select
MsgBox "2.Error"
End If
End If
End If
End If
End Sub

vba select offset cell after selecting target? Not working?

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

Resources