I am using the following code to try and take the user to the first available empty row. This is designed to act as a kind of go to the first empty row link.
Code:
'Go Bottom
If Target.Address = "$K$3" Then
Range("A8").End(xlDown).Offset(1, 0).Select
End If
The code selects the last used row but does not scroll the cell into view.
The user still has to scroll down.
Please can someone show me where i am going wrong?
Full Code:
Option Explicit
Option Compare Text
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Go Bottom
If Target.Address = "$K$3" Then
Range("A8").End(xlDown).Offset(1, 0).Select
End If
'Clear Search Box
If Target.Address = "$L$3:$M$3" Then
On Error Resume Next
Target.Cells.Interior.Pattern = xlNone
Target.Cells.Value = ""
SendKeys "{F2}"
Else
If Target.Address <> "$L$3:$M$3" Then
Range("L3").Value = "Search Supplier Name, Number"
End If
End If
Message:
Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Message
On Error Resume Next
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Insert Depot Memo Data for user
Dim oCell As Range, targetCell As Range
Dim ws2 As Worksheet
On Error GoTo Message
If Not Intersect(Target, Range("B:B")) Is Nothing Then ' <-- run this code only if a value in column B has changed
If Not GetWb("Depot Memo", ws2) Then Exit Sub
With ws2
For Each targetCell In Target
Set oCell = .Range("J1", .Cells(.Rows.Count, "J").End(xlUp)).Find(What:=targetCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not oCell Is Nothing Then
Application.EnableEvents = False
'Set Format of cell
targetCell.ClearFormats
targetCell.Font.Name = "Arial"
targetCell.Font.Size = "10"
targetCell.Font.Color = RGB(128, 128, 128)
targetCell.HorizontalAlignment = xlCenter
targetCell.VerticalAlignment = xlCenter
targetCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
targetCell.Borders(xlEdgeTop).LineStyle = xlContinuous
targetCell.Borders.Color = RGB(166, 166, 166)
targetCell.Borders.Weight = xlThin
targetCell.Offset(0, -1).Value = Now()
targetCell.Offset(0, 1).Value = oCell.Offset(0, 1)
targetCell.Offset(0, 2).Value = oCell.Offset(0, -2)
targetCell.Offset(0, 3).Value = oCell.Offset(0, -7)
Application.EnableEvents = True
End If
Next
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
'Prompt missed on sale
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value = "Issue Complete" Then
If Target.Cells.Count < 8 Then
Dim MSG1 As Variant
MSG1 = MsgBox("Did Item Miss On-Sale?", vbYesNo, "Feedback")
If MSG1 = vbYes Then
Range("O" & ActiveCell.Row).Value = "Yes"
Else
Range("O" & ActiveCell.Row).Value = "No"
End If
Range("P" & ActiveCell.Row).Value = DateDiff("d", CDate(Format(Range("A" & ActiveCell.Row).Value, "dd/mm/yyyy;#")), Date)
End If
End If
If Not Intersect(Target, Range("D" & ActiveCell.Row)) Is Nothing And Target.Value <> "" Then
Call PhoneBook2
End If
'Send Email - Receipt of Issue
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
If Not Intersect(Target, Range("F:F")) Is Nothing Then
If Target.Cells.Count < 8 Then
If Target.Cells.Offset(0, 8).Value = "" Then
Call SendEmail0
End If
End If
End If
'Send Email - Status Change
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
If Not Intersect(Target, Range("N:N")) Is Nothing Then
If Target.Cells.Count < 8 Then
If Target.Cells.Offset(0, 8).Value = "" Then
Call SendEmail
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Message:
Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
Thanks
Try this...
Application.Goto Range("A8").End(xlDown).Offset(1, 0) , True
Did you try like this:
If Target.Address = "$K$3" Then
Range("A8").End(xlDown).Offset(1, 0).Activate
End If
you can also find the last row and then go one more row like this
Dim lastRowSheetSix As Long
lastRowSheetSix = ThisWorkbook.Worksheets("PrepareEmailTL-RRD").Range("C1").SpecialCells(xlCellTypeLastCell).Row
lastRowSheetSix=lastRowSheetSix+1
lastRowSheetSix.Select or (Activate) as you wish
Related
I'm trying to make an excel where other users can only change a range of cells dependent on an other cell they can change as well (B2). The independent cell B2 is a dropdownlist where they can choose from and can have 4 values. I looked on internet and found examples of independent cells having 2 values. I based myself on this. When I check my code when I didn't protect my worksheet yet it looks like the right cells are locked and unlocked. From the moment I change it to protected sheet I get Run time error 1004:Unable to set locked property of ranged class. I tried to solve it but can't find to fix it. Does someone has an idea where I'm going wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("B2") = "text 1" Then
Range("F4:Q4").Locked = True
Range("B2").Locked = False
ElseIf Range("B2") = "Text 2" Then
Range("F4:I4").Locked = False
Range("B2").Locked = False
Range("J4:Q4").Locked = True
ElseIf Range("B2") = "Text 3" Then
Range("B4:Q4").Locked = False
Range("B2").Locked = False
ElseIf Range("B2") = "text 4" Then
Range("B4:Q4").Locked = False
Range("B2").Locked = False
End If
End Sub
I was able to solve it with following code
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("B2") = "Text 1" Then
Sheet2.Unprotect Password:="Secret"
Range("F4:Q4").Locked = True
Range("B2").Locked = False
Sheet2.Protect Password:="Secret"
ElseIf Range("B2") = "text 2" Then
Sheet2.Unprotect Password:="Secret"
Range("F4:I4").Locked = False
Range("B2").Locked = False
Range("J4:Q4").Locked = True
Sheet2.Protect Password:="Secret"
ElseIf Range("B2") = "text 3" Then
Sheet2.Unprotect Password:="Secret"
Range("B4:Q4").Locked = False
Range("B2").Locked = False
Sheet2.Protect Password:="Secret"
ElseIf Range("B2") = "text 4" Then
Sheet2.Unprotect Password:="Secret"
Range("B4:Q4").Locked = False
Range("B2").Locked = False
Sheet2.Protect Password:="Secret"
End If
Now I'm trying to put back in code that was also embedded in worksheet_change
If Target.Column = 2 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
This gives me error that I have protected sheet. I thought solving it like this.
Sheet2.Unprotect Password:="Secret"
If Target.Column = 2 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
Sheet2.Protect Password:="Secret"
If I do this it does no longer erase value next to dropdownlist. Any clue why it no longer does this?
Following advice from here, Loop through named range list, I have tried to make the following code more efficient with a loop.
Sub Worksheet_Calculate()
Application.EnableEvents = False
Range("in1.1").Rows.EntireRow.Hidden = (Range("in1.1").Cells(1, 1).Value = "No")
Range("in1.2").Rows.EntireRow.Hidden = (Range("in1.2").Cells(1, 1).Value = "No")
Application.EnableEvents = True
End Sub
However, I still get a runtime error of various flavors, and I don't really understand how VBA properties work.
Sub Worksheet_Calculate()
Application.EnableEvents = False
Dim TargetSheetName As String
TargetSheetName = "Input data"
For Each nmdrange In ThisWorkbook.Names
If Range(nmdrange.RefersTo).Parent.Name = TargetSheetName Then
'Loop over benefits
Range(nmdrange).Rows.EntireRow.Hidden = (Range(nmdrange).Cells(1, 1).Value = "No")
End If
Next nmdrange
Application.EnableEvents = True
End Sub
This worked for me:
Sub Worksheet_Calculate()
Dim nmdrange As Name, rng As Range
On Error GoTo haveError
Application.EnableEvents = False
For Each nmdrange In ThisWorkbook.Names
Set rng = Range(nmdrange.RefersTo) '<< set a variable to simplify subsequent code
'you can use Me to refer to the sheet where this code is running
If rng.Parent.Name = Me.Name Then
'Loop over benefits
rng.Rows.EntireRow.Hidden = (rng.Cells(1, 1).Value = "No")
End If
Next nmdrange
haveError:
'## alert if error
If Err.Number <> 0 Then MsgBox "Error" & Err.Description
Application.EnableEvents = True
End Sub
I'm pretty new to this topic Worksheet_Change. I wanted to put those 3 events together in one sheet. Could someone help me with this problem?
First and second one give me only date and user name in diffrent cells
second one blockes all cells after writing something in it. I have already tried all...
Code 1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rC As Range
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rC In Target.Cells
Range("F" & rC.Row) = Now()
Range("G" & rC.Row) = Environ("username")
Next rC
Application.EnableEvents = True
End Sub
Code 2:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim P2 As Range
If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each P2 In Target.Cells
Range("H" & P2.Row) = Now()
Range("I" & P2.Row) = Environ("username")
Next P2
Application.EnableEvents = True
End Sub
Code 3:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
ActiveSheet.Unprotect Password:="Athens"
For Each cel In Target
If cel.Value <> "" Then
cel.Locked = True
End If
Next cel
ActiveSheet.Protect Password:="Athens"
End Sub
Like so?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rC As Range
Dim P2 As Range
Dim cel As Range
If Not Intersect(Target, Range("B:B")) Is Nothing Then
Application.EnableEvents = False
For Each rC In Target.Cells
Range("F" & rC.Row) = Now()
Range("G" & rC.Row) = Environ("username")
Next rC
Application.EnableEvents = True
ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For Each P2 In Target.Cells
Range("H" & P2.Row) = Now()
Range("I" & P2.Row) = Environ("username")
Next P2
Else
Application.EnableEvents = True
ActiveSheet.Unprotect Password:="Athens"
For Each cel In Target
If cel.Value <> "" Then
cel.Locked = True
End If
Next cel
ActiveSheet.Protect Password:="Athens"
End If
End Sub
needed to change it to make it work as intended. I wanted to block all cells which were modified by direct interaction. Thanks for help! I couldn't do it without your help
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rC As Range
Dim P2 As Range
Dim cel As Range
Application.EnableEvents = True
ActiveSheet.Unprotect Password:="Athens"
For Each cel In Target
If cel.Value <> "" Then
cel.Locked = True
End If
Next cel
ActiveSheet.Protect Password:="Athens"
If Not Intersect(Target, Range("B:B")) Is Nothing Then
Application.EnableEvents = False
For Each rC In Target.Cells
Range("F" & rC.Row) = Now()
Range("G" & rC.Row) = Environ("username")
Next rC
Application.EnableEvents = True
ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
For Each P2 In Target.Cells
Range("H" & P2.Row) = Now()
Range("I" & P2.Row) = Environ("username")
Next P2
Application.EnableEvents = True
End If
End Sub
I have the below code in my worksheet.
The code causes the spreadsheet to works slow and crash and it also takes ages to open. I am brand new to VBA and may not be coding this correctly. Is there a better way of structuring my code to prevent this from happening?
Option Explicit
Option Compare Text
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
If Target.Address = "$K$3" Then
If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
Range("A5").Select
Else
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
End If
End If
If Target.Address = "$I$3" Then
If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
Range("A5").Select
Else
Range("A9").Select
End If
End If
If Target.Address = "$N$2" Then
If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
Range("A5").Select
Else
Range("A7").Select
End If
End If
'Clear Search Box
If Target.Address = "$N$3:$O$3" Then
Target.Value = ""
End If
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Message
On Error Resume Next
ActiveSheet.DisplayPageBreaks = False
'Insert Depot Memo Data for user
Dim oCell As Range, targetCell As Range
Dim ws2 As Worksheet
On Error GoTo Message
If Not Intersect(Target, Range("B:B")) Is Nothing Then ' <-- run this code only if a value in column I has changed
If Not GetWb("Depot Memo", ws2) Then Exit Sub
With ws2
For Each targetCell In Target
Set oCell = .Range("J1", .Cells(.Rows.Count, "J").End(xlUp)).Find(What:=targetCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not oCell Is Nothing Then
Application.EnableEvents = False
'Set Format of cell
targetCell.Font.Name = "Arial"
targetCell.Font.Size = "10"
With targetCell.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = RGB(192, 0, 0)
.Weight = xlMedium
End With
With targetCell.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = RGB(192, 0, 0)
.Weight = xlMedium
End With
With targetCell.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = RGB(191, 191, 191)
.Weight = xlThin
End With
With targetCell.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = RGB(191, 191, 191)
.Weight = xlThin
End With
targetCell.Offset(0, -1).Value = Now()
targetCell.Offset(0, 1).Value = oCell.Offset(0, 1)
targetCell.Offset(0, 2).Value = oCell.Offset(0, -2)
targetCell.Offset(0, 3).Value = oCell.Offset(0, -7)
Application.EnableEvents = True
End If
Next
End With
End If
'Prompt missed on sale
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value = "Issue Complete" Then
If Target.Cells.Count < 8 Then
Dim MSG1 As Variant
MSG1 = MsgBox("Did Item Miss On-Sale?", vbYesNo, "Feedback")
If MSG1 = vbYes Then
Range("O" & ActiveCell.Row).Value = "Yes"
Else
Range("O" & ActiveCell.Row).Value = "No"
End If
Range("P" & ActiveCell.Row).Value = Date - Range("A" & ActiveCell.Row).Value
End If
End If
If Not Intersect(Target, Range("D" & ActiveCell.Row)) Is Nothing And Target.Value <> "" Then
Call PhoneBook2
End If
'Send Email - Receipt of Issue
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value <> "" Then
If Target.Cells.Count < 4 Then
Call SendEmail0
End If
End If
'Send Email - Status Change
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value <> "" Then
If Target.Cells.Count < 4 Then
Call SendEmail
End If
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If ActiveCell.Value = "(Turn Off Emails)" Then
UserForm1.Show
End If
End Sub
Function GetWb(wbNameLike As String, WS As Worksheet) As Boolean
Dim Wb As Workbook
For Each Wb In Workbooks
If Wb.Name Like "*" & wbNameLike & "*" Then '<-- check if workbook name contains "Depot Memo"
Set WS = Wb.Worksheets(1)
Exit For
End If
Next
GetWb = Not WS Is Nothing
End Function
When you select a cell in Selection Change Event code, the selection change event gets triggered again.
Same thing happens when you change the value of a cell in Sheet Change Event, the same event gets triggered again.
So in the background event codes gets triggered multiple time which makes codes execution slow.
To deal with this, you should use Application.EnableEvents = False to avoid the event code to be triggered again.
But remember to enable the events again by Application.EnableEvents = True
Why this code not work?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Len(Target.Value) <> 14 Then
Target.Value = Format(Now(), ["yyyymmddhhmmss"])
Target.NumberFormat = "0"
Else
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
If Not Intersect(Target, Columns(18)) Is Nothing Then
If Len(Target.Value) <> 10 Then
Target.Value = Format(Date, ["yyyy.mm.dd"])
Else
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End Sub
I need to change value in cell if it not already set (I check for string len), so if value is set I need to prevent this value from changes by this macros and let changing only manually.
How to do that?
Start by using Application.EnableEvents = False before changing any values and then Application.EnableEvents = True before exiting. By changing the value(s), you are triggering another event that runs on top of the original and may attempt to undo what you started.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Application.EnableEvents = False
If Not Intersect(Target, Union(Columns(1), Columns(18))) Is Nothing Then
Dim tmp As Variant
tmp = Target.Value
Application.Undo
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Len(Target.Value) <> 14 Then
Target.Value = Format(Now(), ["yyyymmddhhmmss"])
End If
ElseIf Not Intersect(Target, Columns(18)) Is Nothing Then
If Len(Target.Value) <> 10 Then
Target.Value = Format(Date, ["yyyy.mm.dd"])
End If
End If
End If
Application.EnableEvents = True
End Sub
The other hole in your logic was checking the current Target value's length. You needed to undo first to see what the value was before something new was typed in.