So I have this excel worksheet, where I have a range A2:A3, I would like to know if I can store last time of update of that specific range to a cell lets say in B1?
I am really knew in VBA world.
Will really appreciate any help :)
right click your sheet tab
View Code
copy and paste in the code below
altf11 back to Excel
code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Intersect([a2:a3], Target)
If rng1 Is Nothing Then Exit Sub
Application.EnableEvents = False
[b1] = Format(Now(), "dd-mm-yyyy hh:mm:ss")
Application.EnableEvents = True
End Sub
'This Macro has been written to update Last modified date/time on each A2:D43415
'Last Modified date applied to column F.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rInt As Range
Dim rCell As Range
Dim tCell As Range
Dim tColInt As Integer
tColInt = 6 'Column Index, Example: A=1, B=2, ...... ,Z=26
Set rInt = Intersect(Target, Range("A2:D43415")) 'Change cell range
If Not rInt Is Nothing Then
For Each rCell In rInt
Set tCell = Cells(rCell.Cells.Row, tColInt)
If IsEmpty(tCell) Or Not IsEmpty(tCell) Then
tCell = Now
tCell.NumberFormat = "dd/mm/yyyy h:mm:ss AM/PM" 'Custom Format
End If
Next
End If
End Sub
Click to See Output
Related
I'm trying to create a macro that would allow me to extract data from an array to send an email.
The sorting must be done according to the comments. The goal is to detect the date of the day, for example today 22/08/2022, and to extract the line in another page by erasing in the comment box, the comments which are not dated today , ie have the whole line with the last comment in the comment box. On the other hand, if there is no comment dating from today, the line must not be selected or copied.
However, no matter what code I enter, I cannot sort the data according to the date and only retrieve today's comment, knowing that in this excel I only have a few lines but I have to be able to use it for 1000 rows.
How should I go about it?
Thank you and have good day
My example table
The result that I try to have
Solution
Option Explicit
Sub TodaysComments()
Dim srcWs As Worksheet
Dim destWs As Worksheet
Dim myCell As Range
Dim rngToCopy As Range
' Set source and find comments column
Set srcWs = Worksheets("Source")
Set myCell = srcWs.Cells.Find("Commentaires")
If myCell Is Nothing Then
MsgBox "Cannot find column 'Commentaires'!", vbCritical
Exit Sub
End If
' Set and clear destination
Set destWs = Worksheets("Filtered")
destWs.Cells.Clear
' Copy Header
RngCopy CurrentRow(myCell), destWs.Range("A1")
' Loop over comments
NextCell myCell
Do While myCell.Value <> ""
' Search for today's date
If Not myCell.Find(Today) Is Nothing Then
' Aggregate rows to copy
Set rngToCopy = RngUnion(rngToCopy, CurrentRow(myCell))
End If
NextCell myCell
Loop
' No comments today
If rngToCopy Is Nothing Then
MsgBox "No 'Commentaires' rows meet criteria!", vbInformation
Exit Sub
End If
' Copy rows to destination
RngCopy rngToCopy, destWs.Range("A2")
' Clear old comments from destination
Set myCell = destWs.Cells(2, myCell.Column)
Do While myCell.Value <> ""
ClearOldComments myCell
NextCell myCell
Loop
MsgBox "Done!", vbInformation
End Sub
Private Sub RngCopy(SrcRng As Range, DestRng As Range)
SrcRng.Copy
DestRng.PasteSpecial xlPasteAll
DestRng.Range("A1").PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
End Sub
Private Function CurrentRow(myCell As Range) As Range
Set CurrentRow = Range(myCell, myCell.Worksheet.Cells(myCell.Row, 1))
End Function
Private Sub NextCell(myCell As Range)
Set myCell = myCell.Offset(1, 0)
End Sub
Function RngUnion(Rng1 As Range, Rng2 As Range) As Range
If Rng2 Is Nothing Then Err.Raise 91 ' Object variable not set
If Rng1 Is Nothing Then
Set RngUnion = Rng2
Exit Function
End If
Set RngUnion = Union(Rng1, Rng2)
End Function
Private Sub ClearOldComments(myCell As Range)
Dim Comments As Variant
Dim i As Long
Comments = VBA.Split(myCell.Value, vbNewLine)
For i = LBound(Comments) To UBound(Comments)
' NOTE: We assume there is only one comment per day.
If InStr(Comments(i), Today) Then
myCell.Value = Comments(i)
Exit Sub
End If
Next
' Should not be possible
Err.Raise 93 ' Invalid pattern string
End Sub
Function Today() As String
Today = FormatDateTime(Date, vbGeneralDate)
End Function
I would like to apply vba formula to designated cells. The vba I am working on would be: If I type something on C2, a date stamp will be automatically put in D2.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 3 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
With Target.Offset(0, 1)
.Value = Now
.NumberFormat = "MM/DD/YYYY"
End With
End Sub
However, if I typed something on C1, a date stamp will appear as well. How can I limit the range of the vba? For example, I just want the date stamp from D2 to D5.
Thanks!!
You can apply Intersect function to check if target falls into the desired range, like this
Dim dr As Range
Set dr = Range("C2:C5")
If Not Intersect(target, dr) Is Nothing Then
... it is OK, go ahead
EndIf
The first answer is right, however here is the full version of it
Paste this in the Project of the table, not as a VBA module
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("C2:C5"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each rng In WorkRng
If Not VBA.IsEmpty(rng.Value) Then
rng.Offset(0, xOffsetColumn).Value = Now
rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
Else
rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
So I know that one can format cells to be locked and then protect a worksheet to prevent that data being overwritten. But I'm looking to be able to dynamically lock cells within a sheet. From doing some Googling I've tried adapting the below block of code for my needs. The intent is that if column A has a value the rest of the row will be locked so no one can overwrite the rest of the row.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(ActiveSheet.Cells(18, 1), Target) Is Not Nothing Then
If ActiveSheet.Cells(18, 1).Text = "X" Then
ActiveSheet.Range(Cells(18, 2), Cells(18, 20)).Locked = True
Else
ActiveSheet.Range(Cells(18, 2), Cells(18, 20)).Locked = False
End If
End If
End Sub
Any help would be much appreciated, as well as tips for succinctly applying this to every row in the sheet.
UPDATE:
Per BigBen's answer I've revised to the following:
Private Sub Workbook_Open()
Sheets(“Sheet8”).Protect Password:="Secret", UserInterFaceOnly:=True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Me.Columns(1), Target)
If rng Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In rng
cell.EntireRow.Locked = (cell.Value = "X")
Next
End Sub
But that still doesn't seem to be working...
You need to change the Intersect to test if Target intersects column A, and not a particular cell:
Note also the Not syntax: If Not Intersect... Is Nothing, instead of If Intersect... Is Not Nothing.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.Columns(1), Target) Is Nothing Then
Dim rng as Range
For Each rng in Intersect(Me.Columns(1), Target)
If rng.Value = "X" Then
rng.EntireRow.Locked = True
Else
rng.EntireRow.Locked = False
End If
Next
End If
End Sub
Or perhaps a bit more succinctly:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Me.Columns(1), Target)
If rng Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In rng
cell.EntireRow.Locked = (cell.Value = "X")
Next
End Sub
I would like to display a msgbox if the formula fuelled cell in column I:I changes to TRUE after the cell in column D:D is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
myRange = Range("D:D")
If Intersect(myRange, Target) Then
If Target.Offset(0, 3).Value = True Then MsgBox "Date Range and Holiday Type Mismatch"
End If
End Sub
This is an exaxmple of the table. Basically i will update column D:D with the holiday type. In column I:I the cell will change to TRUE if the date range is not acceptable. If the cell in column I:I changes to TRUE i want the msg box to display.
A good starting attempt, but several issues, including the need for Set when working with Range objects, and an offset that seems... off.
Here's one approach:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Set myRng = Intersect(Target, Me.Columns("D:D"))
If myRng Is Nothing Then Exit Sub
Dim myCell As Range
For Each myCell In myRng
If Me.Cells(myCell.Row, "I").Value = True Then
MsgBox "Date Range and Holiday Type Mismatch"
End If
Next
End Sub
I have problem in my code, i need to change in another column - row
I tried to built macro but it's dosn't work with that.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range
On Error Resume Next
Set xRg = Intersect(Target, Range("A6:U1000"))
If xRg Is "YES" Then Exit Sub
Range("G" & Target.Row).Value = "CHECK"
End Sub
When in column N6:N1000 is "YES" in Column G change value to "Check" and all row A6 for example to U1000 is in color red
I can't quite understand what you're trying to achieve here, but hopefully the below will be doing roughly what you need. Try it and let me know if it doesn't behave the way you hope.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim xRg As Range, cl as Range
Set xRg = Intersect(Target, Range("A6:U1000"))
If Not xRg Is Nothing Then
For Each cl In xRg.Cells
If cl.Value = "YES" Then Range("G" & cl.Row).Value = "CHECK"
Next
End If
Application.EnableEvents = True
End Sub