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
Related
I have been trying to format cells in different rows one with number and another with date using VBA . My code is as below. But the second event is not getting triggered. When I interchange the 1s and 2nd event up to down (date first and number second), date format works and number doesn't works. Can I get any help here please?
*Private Sub Worksheet_Change(ByVal Target As Range)
'___________ 8 DIGITS FORMAT ____________________
Dim i As Integer
Dim cell As Integer
Application.EnableEvents = False
On Error GoTo Err 'To avoid error when multiple cells are selected
If Not Intersect(Target, Range("U:U")) Is Nothing Or _
Not Intersect(Target, Range("B:B")) And Target.Value <> "" Then
cell = Target.Rows.Count
For i = 1 To cell
'To avoid cells with NO VALUE to be FORMATTED
If Target.Cells(i, 1).Value <> "" Then
Target.Cells(i, 1).NumberFormat = "#"
Target.Cells(i, 1).Value = Application.WorksheetFunction.Text(Target.Cells(i, 1).Value, "00000000")
Else
Resume LetsContinue
End If
Next i
End If
Application.EnableEvents = True
'______________________ Date Format ____________________
Dim x As Integer
Dim dt As Integer
Application.EnableEvents = False
On Error GoTo Err2 'To avoid error when multiple cells are selected
If Not Intersect(Target, Range("E:E")) Is Nothing Or _
Not Intersect(Target, Range("AQ:AQ")) And Target.Value <> "" Then
dt = Target.Rows.Count
For x = 1 To dt
'To avoid cells with NO VALUE to be FORMATTED
If Target.Cells(x, 1).Value <> "" Then
Target.Cells(x, 1).NumberFormat = "dd-Mmm-yyyy"
Target.Cells(x, 1).Value = Application.WorksheetFunction.Text(Target.Cells(x, 1).Value, "dd-Mmm-yyyy")
Else
Resume LetsContinue
End If
Next x
Else
End If
Application.EnableEvents = True
Err:
If Not Intersect(Target, Range("U:U")) Is Nothing Or Not Intersect(Target, Range("B:B")) Is Nothing Then
Resume Next
Else
Resume LetsContinue
End If
Err2:
If Not Intersect(Target, Range("E:E")) Is Nothing Or Not Intersect(Target, Range("AQ:AQ")) Is Nothing Then
Resume Next
Else
Resume LetsContinue
End If
LetsContinue:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Whoa:
Resume LetsContinue
End Sub*
A Worksheet Change: Formats and Values in Multiple Columns
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rg As Range
Dim irg As Range
' 8 digits
Set rg = RefColumns(Me, 2, "B,U")
Set irg = Intersect(rg, Target)
If Not irg Is Nothing Then
Format8Digits irg
Set irg = Nothing
End If
' Dates
Set rg = RefColumns(Me, 2, "E,AQ")
Set irg = Intersect(rg, Target)
If Not irg Is Nothing Then
FormatDates irg
Set irg = Nothing
End If
End Sub
Function RefColumns( _
ByVal ws As Worksheet, _
ByVal FirstRow As Long, _
ByVal ColumnsList As String, _
Optional ByVal Delimiter As String = ",") _
As Range
Dim Cols() As String: Cols = Split(ColumnsList, ",")
Dim rResize As Long: rResize = ws.Rows.Count - FirstRow + 1
Dim trg As Range
Dim rg As Range
Dim n As Long
For n = 0 To UBound(Cols)
Set rg = ws.Cells(FirstRow, Cols(n)).Resize(rResize)
If trg Is Nothing Then Set trg = rg Else Set trg = Union(trg, rg)
Next n
Set RefColumns = trg
End Function
Sub Format8Digits(ByVal rg As Range)
On Error GoTo ClearError
Application.EnableEvents = False
Dim Cell As Range
For Each Cell In rg.Cells
If Len(CStr(Cell.Value)) > 0 Then
Cell.NumberFormat = "#"
Cell.Value = Application.WorksheetFunction _
.Text(Cell.Value, "00000000")
End If
Next Cell
SafeExit:
Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
Sub FormatDates(ByVal rg As Range)
On Error GoTo ClearError
Application.EnableEvents = False
Dim Cell As Range
For Each Cell In rg.Cells
If IsDate(Cell) Then
Cell.NumberFormat = "dd-Mmm-yyyy"
Cell.Value = Application.WorksheetFunction _
.Text(Cell.Value, "dd-Mmm-yyyy")
End If
Next Cell
SafeExit:
Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I found solution for this query after 2 months.
In the first event when we give Resume LetsContinue which actually ends the code, 2nd event should be triggered for which 2nd and subsequent events should be given defined with names and Resume "Events" in 1st event.
Here is how it should be:
Resume Event2
End If
Next i
End If
Application.EnableEvents = True
'______________________ Date Format ____________________
Event2:
Dim x As Integer
Dim dt As Integer
Application.EnableEvents = False
On Error GoTo Err2 'To avoid error when multiple cells are selected
If Not Intersect(Target, Range("E:E")) Is Nothing Or _
Not Intersect(Target, Range("AQ:AQ")) And Target.Value <> "" Then
dt = Target.Rows.Count
And the code continues----------------
Fairly new to VBA and Macros, and I would need assistance in combining these 2 worksheet events. Both work individually and I haven't found a way to combine them to run.
Macro 1: Automatically updating Timestamp Data Entries
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range
Set myTableRange = Range("W4:W3000")
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set myDateTimeRange = Range("AF" & Target.Row)
Set myUpdatedRange = Range("AG" & Target.Row)
If myDateTimeRange.Value = "" Then
myDateTimeRange.Value = Now
End If
myUpdatedRange.Value = Now
Application.EnableEvents = True
End Sub
Macro 2: Allowing for multiple selection in Dropdown lists
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, "; " & xValue2) Or _
InStr(1, xValue1, xValue2 & ";") Then
Target.Value = xValue1
Else
Target.Value = xValue1 & "; " & xValue2
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
Any help/guidance would be greatly appreciated.
Thank you!
Create a module and add two subs there:
Option Explicit
Public Sub updateTimestampDataEntries(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Public Sub allowMultipleSelectionDropdown(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Then you can use these subs within your worksheet_events like this
Private Sub Worksheet_Change(ByVal Target As Range)
dim c as Range: set c = Target.Cells(1,1) 'only check the first cell
If Not Application.Intersect(c, rgMyTable) Is Nothing Then
updateTimestampDataEntries c
ElseIf not Application.Intersect(c, rgValidationLists) Is Nothing Then
allowMultipleSelectionDropdown c
End If
End Sub
Private Property Get rgMyTable() as Range
'put your code here
set rgMyTable = ...
End Property
Private Property Get rgValidationLists as range
'put your code here
set rgValidationLists = ...
End Property
New to VBA. Wondering how I can make my code more efficient.
I've created an order form with 50 order lines, i.e. you can order at most 50 items using this sheet. Each item has 3 possible customizations which will determine the product SKU. I've written the following code to "reset" the customization choices if you change the item choice for each line (only showing code for first 3 lines, but this repeats for all 50 lines). Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("L1RoomType")) Is Nothing Then
Range("L1Dis").Value = Range("L1DisDefault").Value
End If
If Not Intersect(Target, Range("L1RoomType")) Is Nothing Then
Range("L1Pwr").Value = Range("L1PwrDefault").Value
End If
If Not Intersect(Target, Range("L1RoomType")) Is Nothing Then
Range("L1TM").Value = Range("L1TMDefault").Value
End If
If Not Intersect(Target, Range("L2RoomType")) Is Nothing Then
Range("L2Dis").Value = Range("L2DisDefault").Value
End If
If Not Intersect(Target, Range("L2RoomType")) Is Nothing Then
Range("L2Pwr").Value = Range("L2PwrDefault").Value
End If
If Not Intersect(Target, Range("L2RoomType")) Is Nothing Then
Range("L2TM").Value = Range("L2TMDefault").Value
End If
If Not Intersect(Target, Range("L3RoomType")) Is Nothing Then
Range("L3Dis").Value = Range("L3DisDefault").Value
End If
If Not Intersect(Target, Range("L3RoomType")) Is Nothing Then
Range("L3Pwr").Value = Range("L3PwrDefault").Value
End If
If Not Intersect(Target, Range("L3RoomType")) Is Nothing Then
Range("L3TM").Value = Range("L3TMDefault").Value
End If
Application.EnableEvents = True
End Sub
Take advantage in the patterns in your naming.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim IntersectRange As Range
Dim RoomNum As Long
On Error GoTo EH ' Ensure events get turned back on
Application.EnableEvents = False
For RoomNum = 1 To 3 ' or 50?
Set IntersectRange = Intersect(Target, Me.Range("L" & RoomNum & "RoomType"))
If Not IntersectRange Is Nothing Then
Me.Range("L" & RoomNum & "Dis").Value = Me.Range("L" & RoomNum & "DisDefault").Value
Me.Range("L" & RoomNum & "Pwr").Value = Me.Range("L" & RoomNum & "PwrDefault").Value
Me.Range("L" & RoomNum & "TM").Value = Me.Range("L" & RoomNum & "TMDefault").Value
End If
Next
EH:
Application.EnableEvents = True
End Sub
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
i'm clueless, i'm trying to build a code that input a prefix to a cell value after i change that cell, i mean i'll select a cell and input "342" for example, after i update that value i want the private sub to change that cell value to "GO-342", i've tried this, but it dosen't work.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Range("D3") = "GO-" & Range("D3")
End If
End Sub
the entire code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Cabeçalho
Dim rng As Range
Set rng = Range("D3,D5,I3,O3,O5,O7,X3,X5")
If Intersect(Target, rng) Is Nothing Then Exit Sub
For Each R In rng
If R.Value = "" Then
Exit Sub
End If
Next R
Create
'Km
Dim rng1 As Range
Set rng1 = Range("X3,X5")
If Intersect(Target, rng1) Is Nothing Then Exit Sub
For Each R In rng1
If R.Value = "" Then
Exit Sub
End If
Next R
Km
'GO
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Application.EnableEvents = False
Range("D3") = "GO-" & Range("D3")
Application.EnableEvents = True
End If
End Sub
"Cabeçalho" and "Km" works but "GO" dosen't
Here is a tiny mod to your code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Application.EnableEvents = False
Range("D3") = "GO-" & Range("D3")
Application.EnableEvents = True
End If
End Sub
The code must be placed in the worksheet code area.Macros must be enabled.