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
Related
I have a spreadsheet like this, and I would like to have a function that returns the list of row numbers non-empty cells in column B. In this case, it should return "2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 16, 18, 20, 21, 22, 23, 25, 26)
How do I do this in VBA?
Function GetEmptyCount()
Dim arr(), x&, cell
With Range("B1:B" & Cells(Rows.Count - 1, "B").End(xlUp).Row)
For Each cell In .SpecialCells(xlCellTypeBlanks).Cells
x = x + 1
ReDim Preserve arr(1 To x)
arr(x) = cell.Row
Next
End With
GetEmptyCount = arr
End Function
Sub Test()
Dim x, c
x = GetEmptyCount()
For Each c In x: MsgBox c: Next
End Sub
You can check the length of the cell value something like
IF(Length(Cell) > 0 THEN
// Include the row
ELSE
// skip the row
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
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.
I have written some code that populates a preformatted worksheet in an another workbook, from another preformatted worksheet. They include merged cells and all other things nasty, and for whatever reason cannot be changed.
So, I have written the following
Sub test()
Dim wbkCurrent As Workbook
'Dim wbk3Mth As Workbook
Dim wbk6Mth As Workbook
Set wbkCurrent = ThisWorkbook
Set wbk6Mth = Workbooks.Open("C:\newbook.xlsm")
newbook.Sheets("Mon 1").Activate
Call assignArrays
End Sub
Sub assignArrays
Call moveValues(32, 3, 7, 8)
Call moveValues(32, 5, 23, 6)
Call moveValues(32, 65, 15, 8)
Call moveValues(32, 56, 31, 5)
Call moveValues(32, 57, 31, 11)
Call moveValues(32, 15, 39, 4)
Call moveValues(32, 16, 39, 5)
Call moveValues(32, 17, 39, 6)
Call moveValues(32, 18, 39, 7)
Call moveValues(32, 30, 39, 10)
Call moveValues(32, 31, 39, 11)
Call moveValues(32, 32, 39, 12)
Call moveValues(32, 33, 39, 13)
Call moveValues(32, 7, 7, 21)
Call moveValues(32, 9, 23, 19)
Call moveValues(32, 66, 15, 21)
Call moveValues(32, 59, 31, 18)
Call moveValues(32, 60, 31, 24)
Call moveValues(32, 20, 39, 17)
Call moveValues(32, 21, 39, 18)
Call moveValues(32, 22, 39, 19)
Call moveValues(32, 23, 39, 20)
Call moveValues(32, 35, 39, 23)
Call moveValues(32, 36, 39, 24)
Call moveValues(32, 37, 39, 25)
Call moveValues(32, 38, 39, 26)
Call moveValues(32, 11, 7, 34)
Call moveValues(32, 13, 23, 32)
Call moveValues(32, 67, 15, 34)
Call moveValues(32, 62, 31, 31)
Call moveValues(32, 63, 31, 37)
Call moveValues(32, 25, 39, 30)
Call moveValues(32, 26, 39, 31)
Call moveValues(32, 27, 39, 32)
Call moveValues(32, 28, 39, 33)
Call moveValues(32, 40, 39, 36)
Call moveValues(32, 41, 39, 37)
Call moveValues(32, 42, 39, 38)
Call moveValues(32, 43, 39, 39)
End Sub
Sub moveValues(tRow, tCol, rRow, rCol)
'trow is row in this workbook, tcol is column in this workbook, rRow & rCol are the same for the other workbook
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
tRow = tRow + 1
rRow = rRow + 1
ActiveSheet.Cells(rRow, rCol).Value = ThisWorkbook.Sheets("Results").Cells(tRow, tCol).Value
End Sub
This works fine, and writes all the data out. Problem is, I need this to run starting where
trow = 2,12,22,32,42,52
Now I could write this all out manually, but it would mean that going in and changing it later would be a nightmare. So, I had the idea of using a = 2,12,22,32 etc and then having
call moveValues(a, 3, 7, 8)
However this means a bumps up a digit through the moveValues subroutine, and needs resetting each time.
I have one idea to solve this using arrays, but that has its own issues.
I replaced the module assignArrays with
Sub assignArrays()
'row in this workbook
Dim array1(5)
array1(5) = Array(2, 12, 22, 32, 42, 52)
'E
Dim array2(12)
array2(12) = Array(3, 5, 65, 56, 57, 15, 16, 17, 18, 30, 31, 32, 33)
'U
Dim array2_1(12)
array2_1(12) = Array(7, 9, 66, 59, 60, 20, 21, 22, 23, 35, 36, 37, 38)
'R
Dim array2_2(12)
array2_2(12) = Array(11, 13, 67, 62, 63, 25, 26, 27, 28, 40, 41, 42, 43)
'row in report
Dim array3(12)
array3(12) = Array(7, 23, 15, 31, 31, 39, 39, 39, 39, 39, 39, 39, 39) 'constant in each array 1
'column in report
Dim array4(12)
array4(12) = Array(8, 6, 8, 5, 11, 4, 5, 6, 7, 10, 11, 12, 13) '+13 for each third
Dim v1, v2, v3, v4 As Integer
For a = 0 To 5
v1 = array1(a)
For b = 0 To 12
v3 = array3(b)
For c = 0 To 12
v4 = array4(c)
For d = 0 To 12
v2 = array2(d)
Call moveValues(v1, v2, v3, v4)
Next d
Next c
For c = 0 To 12
v4 = array4(c) + 13
For d = 0 To 12
v2 = array2(d)
Call moveValues(v1, v2, v3, v4)
Next d
Next c
For c = 0 To 12
v4 = array4(c) + 26
For d = 0 To 12
v2 = array2(d)
Call moveValues(v1, v2, v3, v4)
Next d
Next c
Next b
Next a
End Sub
This dies with a 1004 error on the first line of moveValues. Any ideas to fix either solution?
You are not dealing with arrays properly.
Dim array1(5) 'Array with 5 dimension
array1(5) = Array(2, 12, 22, 32, 42, 52) 'Write all this content to the fifth position
The proper way to do that is:
Dim array1(5) As Integer
array1(0) = 2
array1(1) = 12
array1(2) = 22
array1(3) = 32
array1(4) = 42
array1(5) = 52
If you want to rely on one line, you can do:
Dim array1
array1 = Array(2, 12, 22, 32, 42, 52) 'In this case, it starts from 0 -> pretty unconventional (bear in mind that the array above is dimensioned from 1)
---- UPDATE
What your code delivers:
Dim array1(5)
array1(5) = Array(2, 12, 22, 32, 42, 52)
Dim test1 As Integer: test1 = array1(0) '-> 0
Dim test2 As Integer: test2 = array1(1) '-> 0
Dim test3 As Integer: test3 = array1(2) '-> 0
Dim test4 As Integer: test4 = array1(3) '-> 0
Dim test5 As Integer: test5 = array1(4) '-> 0
Dim test6 As Integer: test6 = array1(5) 'ERROR
What my code delivers:
Dim array1
array1 = Array(2, 12, 22, 32, 42, 52)
Dim test1 As Integer: test1 = array1(0) '-> 2
Dim test2 As Integer: test2 = array1(1) '-> 12
Dim test3 As Integer: test3 = array1(2) '-> 22
Dim test4 As Integer: test4 = array1(3) '-> 32
Dim test5 As Integer: test5 = array1(4) '-> 42
Dim test6 As Integer: test6 = array1(5) '-> 52