I have a vba script i am working on. It applies a time stamp each time the relevant cell is double clicked. Once its double clicked the cells are locked.
When the cell is double clicked on again a pop up box appears requesting a password, which is fine.
Problem: However i want the cell to be left unprotected until it gets double clicked again.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30 - 35, 37, 38, 40, 42 - 44, 54 - 56, 58, 59, 61 - 65
ActiveSheet.Protect Password:="Test", userinterfaceonly:=True
.Value2 = "Prepared By" & " " & Environ("Username")
.Value2 = .Value2 & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
.Locked = True
ActiveSheet.Unprotect
End Select
End If
End With
Edited as per below answer , however user is able double click the protect cell which still changes regards password is entered or not.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
If InStr(1, Target.Value2, "##") = 0 Then
Target.Value2 = Target.Value2 & "##"
Else
ActiveSheet.Protect Password:="Test", userinterfaceonly:=True
.Value2 = "Prepared By" & " " & Environ("Username")
.Value2 = .Value2 & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
.Locked = True
ActiveSheet.Unprotect
End If
End Select
End If
End With
Related
I have been doing a little bit of research if its possible to highlight cells which have been manually amended (by typing in the information) as oppose via marco. What i really came across was track changes which might not apply in this situation
Scenario
I have a macro which runs each time certain cells are double clicked. When a cell is double clicked a timestamp is provided, which is perfectly fine.
Problem
I am trying to aviod the situation were a user tries to amend the time stamp manually, or any of that information in that relevant cell. I am trying to aviod using the methdology of locking cells once update.
Solution to be achieved.
Is it possible that if a cell has been manually updated by user that its highlighted. However if it has been update through the use of the macro thats ok.
Code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username")
.Value2 = .Value2 & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
The simplest solution to this would just to be enforce any changes to your selected cells with the change event. I assume the double click aspect is to make it more user friendly for the input so we won't remove that, rather duplicate it:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
If Target.Cells.Count = 1 Then
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
Else
For Each cell In Target.Cells
With cell
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End Select
End If
End With
Next cell
End If
End Sub
I am currently working with two pieces of vba code. I am trying to marry them together to achieve the below purpose.
First code
I have code that allows users to double click on a cell and then it time stamps the cell, and subsequently locks the relevant cell. Which works fine. However is some instances the user will have to type in NA and different piece of code will run ( Second code).
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
Sheets("Sheet3").Protect Password:="Test", userinterfaceonly:=True
.Value2 = "Prepared By" & " " & Environ("Username")
.Value2 = .Value2 & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
.Locked = True
End Select
End If
End With
End Sub
Second Code when user Types NA
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'// Check if the target row number is in our array:
Select Case Target.Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
' Do Something
If CStr(Target.Value) Like "*NA*" Then
Target.Value = "Not applicable" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
End If
Case Else
' Do nothing
Exit Sub
End Select
End Sub
Problem to Overcome
Once the user double clicks on a the cell and it locks , there are not able to later change that cell to NA. NA should be the only value that the user should be able to type once cell is locked.
Question
Is there a way that i can allow the user to type in NA only once the cell is locked. Therefore user only has two options to type na or Double click
Obviously you can't type anything until a cell is locked. Add data validation to allow "NA" only instead of locking the cell. Something like this:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Row
Case 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65
.Value2 = "Prepared By" & " " & Environ("Username") & " " & Format(Now, "yyyy-MM-dd hh:mm:ss")
With .Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="NA"
.IgnoreBlank = False
.InCellDropdown = False
.ErrorTitle = "Invalid input"
.ErrorMessage = "NA available only"
.ShowError = True
End With
End Select
End If
End With
Application.EnableEvents = True
End Sub
This method assumes that the worksheet isn't protected at all.
The below code of mine works well the issue I have is that my ranges have now expanded and i need a more efficient way to approach it.
The Code updates my Date worksheet sheet when the below ranges have been updated and file also saved ( both conditions need to be met) . Any advice?
Sheet3.Range D ( 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65)
Sheet3.Range E ( 20, 24, 25, 27, 28, 30, 31, 32, 33, 34, 35, 37, 38, 40, 42, 43, 44, 54, 55, 56, 58, 59, 61, 62, 63, 64, 65)
'set as public variables to remain saved while workbook is open
Public val1, val2, val3, val4, Val5
Private Sub Workbook_Open()
'set the variables when the workbook is opened
Call SetValues
End Sub
Private Sub SetValues()
'save the values to be checked later
val1 = Sheets("Sheet3").Range("D20").Value
val2 = Sheets("Sheet3").Range("D24").Value
val3 = Sheets("Sheet3").Range("D25").Value
val4 = Sheets("Sheet3").Range("D27").Value
Val5 = Sheets("Sheet3").Range("D28").Value
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet, wsDates As Worksheet
Dim endRow As Long, updateRow As Long, x As Long
Dim checkDate
Set ws = ThisWorkbook.Sheets("Sheet3")
Set wsDates = ThisWorkbook.Sheets("Dates")
'if the values have been changed
If _
val1 <> ws.Range("D20").Value Or _
val2 <> ws.Range("D24").Value Or _
val3 <> ws.Range("D25").Value Or _
val4 <> ws.Range("D27").Value Or _
Val5 <> ws.Range("D28").Value Then
'reset the values to avoid multiple updates
Call SetValues
'set the range of values to check
endRow = wsDates.Cells(wsDates.Rows.Count, 1).End(xlUp).Row
'check to see if an entry was found the same week
For x = 1 To endRow
checkDate = wsDates.Cells(x, 2).Value
If checkDate >= (Date - Weekday(Date, vbSunday) + 1) And checkDate <= (Date - Weekday(Date, vbSaturday) + 1 + 7) Then
updateRow = x
Exit For
End If
Next x
'if an entry the same week wasn't found, set update row to new row
If updateRow = 0 Then updateRow = endRow + 1
'update or add information
wsDates.Cells(updateRow, 1).Formula = Application.UserName
wsDates.Cells(updateRow, 2).Formula = Format(Now, "mm/dd/yyyy")
wsDates.Cells(updateRow, 3).Formula = Format(Now, "HH:mm:ss")
End If
End Sub
Im trying to loop this macro, which changes the color of the row based upon year, through all of my worksheets in a current workbook and can't seem to figure out how to do so. I've tried to piece some stuff together from other questions and answers to no avail. Any help would be appreciated. Here is the code:
Sub ExpirationYeartoColors()
Dim num As Integer, lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Select
For r = 2 To lr
Select Case Range("A" & r).Value
Case Is = "2015"
Range("A" & r).Interior.Color = RGB(181, 189, 0)
Case Is = "2016"
Range("A" & r).Interior.Color = RGB(0, 56, 101)
Case Is = "2017"
Range("A" & r).Interior.Color = RGB(0, 147, 178)
Case Is = "2018"
Range("A" & r).Interior.Color = RGB(155, 211, 221)
Case Is = "2019"
Range("A" & r).Interior.Color = RGB(254, 222, 199)
Case Is = "2020"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case "2020" To "2080"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case Is = "Unknown"
Range("A" & r).Interior.Color = RGB(197, 200, 203)
Case Is = "Available"
Range("A" & r).Interior.Color = RGB(247, 150, 91)
Case Is = "CommonArea"
Range("A" & r).Interior.Color = RGB(230, 230, 230)
Case Else
Range("A" & r).Interior.Color = RGB(255, 255, 255)
End Select
Next r
On Error GoTo ErrorHandler
' Insert code that might generate an error here
Exit Sub
ErrorHandler:
' Insert code to handle the error here
Resume Next
End Sub
I have calculated the count of number of worksheets available on the workbook and stored to a variable. Then used a for loop to loop through the entire workbook till the last worksheet.
The blocked code is the modified part on your code.
Also I see for the case 2020 - 2080, the formatting color is same.
Sub ExpirationYeartoColors()
Dim num As Integer, lr As Long, r As Long
t = ActiveWorkbook.Worksheets.Count
i = 0
For i = 1 To t
Worksheets("sheet" & i).Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Select
For r = 2 To lr
Select Case Range("A" & r).Value
Case Is = "2015"
Range("A" & r).Interior.Color = RGB(181, 189, 0)
Case Is = "2016"
Range("A" & r).Interior.Color = RGB(0, 56, 101)
Case Is = "2017"
Range("A" & r).Interior.Color = RGB(0, 147, 178)
Case Is = "2018"
Range("A" & r).Interior.Color = RGB(155, 211, 221)
Case Is = "2019"
Range("A" & r).Interior.Color = RGB(254, 222, 199)
Case Is = "2020"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case "2021" To "2080"
Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case Is = "Unknown"
Range("A" & r).Interior.Color = RGB(197, 200, 203)
Case Is = "Available"
Range("A" & r).Interior.Color = RGB(247, 150, 91)
Case Is = "CommonArea"
Range("A" & r).Interior.Color = RGB(230, 230, 230)
Case Else
Range("A" & r).Interior.Color = RGB(255, 255, 255)
End Select
Next r
Next i
On Error GoTo ErrorHandler
' Insert code that might generate an error here
Exit Sub
ErrorHandler:
' Insert code to handle the error here
Resume Next
End Sub
This will loop through all the sheets and do the formatting. The code is tested and is working fine
Here is your answer...you need a variable to count the sheets then put your loop inside another "for" to go through all the sheets.
Or you could probably use a while if you wanted..
There are a few ways to loop through the worksheets in a workbook. I prefer the worksheet index method which simply identifies the worksheet according to its position in the worksheet queue.
Sub ExpirationYeartoColors()
Dim w As Long, lr As Long, r As Long, vVAL As Variant
For w = 1 To Worksheets.Count
With Worksheets(w)
lr = .Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
vVAL = .Range("A" & r)
If IsNumeric(vVAL) Then
'treat numbers as numbers!!!
vVAL = Int(vVAL) 'maybe vVAL = Year(vVAL) ?
Select Case vVAL
Case 2015
.Range("A" & r).Interior.Color = RGB(181, 189, 0)
Case 2016
.Range("A" & r).Interior.Color = RGB(0, 56, 101)
Case 2017
.Range("A" & r).Interior.Color = RGB(0, 147, 178)
Case 2018
.Range("A" & r).Interior.Color = RGB(155, 211, 221)
Case 2019
.Range("A" & r).Interior.Color = RGB(254, 222, 199)
Case 2020
.Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case 2021 To 2080
.Range("A" & r).Interior.Color = RGB(238, 242, 210)
Case Else
.Range("A" & r).Interior.Pattern = xlNone
End Select
Else
Select Case vVAL
Case Is = "Unknown"
.Range("A" & r).Interior.Color = RGB(197, 200, 203)
Case Is = "Available"
.Range("A" & r).Interior.Color = RGB(247, 150, 91)
Case Is = "CommonArea"
.Range("A" & r).Interior.Color = RGB(230, 230, 230)
Case Else
.Range("A" & r).Interior.Pattern = xlNone
End Select
End If
Next r
End With
Next w
On Error GoTo ErrorHandler
' Insert code that might generate an error here
Exit Sub
ErrorHandler:
' Insert code to handle the error here
Resume Next
End Sub
There are a number of unanswered questions; particularly about the nature of the data. However, you should be treating numbers as numbers especially if you want to use them in something like Case "2020" To "2080". I've tried to determine the nature of the values and treated text and numbers separately. This compiles but with no sample data or answers to the comments posed I cannot guarantee its validity.
Setting the .pattern to xlNone removes the interior fill rather than painting it white.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
There is an alternative approach using conditional formatting (CF).
The advantage is that once the CF is set up, th formatting of cells will respond to any values that are changed.
You could use VBA code to add CF to all sheets by looping through all sheets in the workbook and running VBA code to add it. OR you could add it manually as follows.
I understand you might need to write VBA code for other reasons and if you do the other answers are good, but I suspect this might work for you.
Select all rows on a sheet (or as many as you need).
Ribbon>HOME>Conditional formatting
Choose: "Use a Formula to determine which cells to format"
Enter this formula "=AND($A1=2010,$A1>0)"
(it assume your data value is in column A
it assumes the first row you selected was row 1)
Enter the formatting you want for the whole row when year in column A=2010
Add one conditional formatting for every year.
I recommend you record a macro and just change it as needed to add CF for every year to every sheet.
Sometimes simple is best.
Harvey
i have a code that has a command button which retrieves its records from an external file.
every time the command button is clicked it will delete all the records and paste again. however it allows the user input for records with "OFM","KH" and "Collar & Cuff" hence it would not delete these rows.
But, my autofilter code is not working properly as it still deletes the rows with "OFM" and "KH""
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=1, Criteria1:="<>OFM", Operator:=xlOr, Criteria2:="<>KH"
the code:
Sub July()
Dim arr, c, b(), n&
Application.ScreenUpdating = False
Worksheets("July 2018").Range("A4").AutoFilter
Workbooks.Open "C:\Users\sophia.tan\Desktop\MasterPlanData.xlsx", 0, 1
arr = Sheets("Excel").UsedRange
ActiveWorkbook.Close 0
c = Array(0, 2, 13, 14, 7, 8, 11, 1, 9, 10, 16, 17, 20, 22, 15, 30, 27, 28,
29, 3, 4, 39)
d = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19,
20, 21, 23)
ReDim b(1 To UBound(arr), 1 To 23)
For i = 2 To UBound(arr)
If arr(i, 13) >= DateSerial(Year:=2018, Month:=7, Day:=1) And arr(i, 12) <=
DateSerial(Year:=2018, Month:=7, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
With Worksheets("July 2018")
.Range("A4:W" &
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=13, Criteria1:="<>Collar & Cuff"
.Range("A4:W" &
Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter
field:=1, Criteria1:="<>OFM", Operator:=xlOr, Criteria2:="<>KH"
.Range("A4:W" & Rows.Count).CurrentRegion.Offset(1,
0).SpecialCells(xlCellTypeVisible).ClearContents
.Range("A4:W" & Rows.Count).Resize(UBound(b, 1), UBound(b, 2)) = b
.AutoFilter.ShowAllData
.Range("A4").CurrentRegion.Sort key1:=Range("G3"), order1:=xlAscending,
Header:=xlYes
.Range("A4").Select
End With
Call Fabrication
Application.ScreenUpdating = 1
End Sub
Your two-criteria-for-one-field AutoFilter logic is flawed. When something is not KH it can be OFM and when something is not OFM it can be KH. I believe you want to filter for not KH and not OFM.
tldr;
You need xlAnd, not xlOr.
'...
With Worksheets("July 2018")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range("A4").CurrentRegion
.AutoFilter Field:=13, Criteria1:="<>Collar & Cuff"
.AutoFilter Field:=1, Criteria1:="<>OFM", Operator:=xlAnd, Criteria2:="<>KH" '<~~ THIS RIGHT HERE
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).ClearContents
End If
End With
.Cells.Sort key1:=.Columns("G"), Order1:=xlAscending, Header:=xlYes
End With
'...
.AutoFilter.ShowAllData
.Range("A4").Select
End With