How to stop code overwriting cells with values in them - excel

I'm trying to tweak the following code which enters today's date in column B when you change column A. I'd only like this code to run when column B is empty as I'm experiencing an issue where worksheet_change is too broad and past dates entered are getting overwritten when new changes are made inadvertently.
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("A:A"), 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 = Date
Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub


You could check if the value is already a date
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("A:A"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
With Rng.Offset(0, xOffsetColumn)
If Not VBA.Information.IsDate(.Value) Then
.Value = Date
.NumberFormat = "mm-dd-yyyy"
End If
End With
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

Related

How do I record Date When Cell Changes?

I have below code when the date is changing while any of cells is updated. But the challenge that I have is with the cell where the date is display. I need the data to be updated always only in column E. How to change - xOffsetColumn = 1 to get there?
Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), 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 = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

This now works for any intersect range.
I tested the below and it works for me.
Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim dateCol%, xOffsetColumn%
Dim Rng As Range, WorkRng As Range
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets(Target.Parent.Name)
'Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
Set WorkRng = Intersect(Application.ActiveSheet.Range("E:AV"), Target)
'dateCol = 5
dateCol = 4
xOffsetColumn = 3
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 = "dd-mm-yyyy, hh:mm:ss"
WS.Cells(Rng.row, dateCol) = Now()
WS.Cells(Rng.row, dateCol).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

How do i populate 2 columns with static dates

Am using the following code that works for populating static dates in column C when data is filled in column B.
I would like to also have column E populated with static dates if data is filled in column D. Please advise tq
Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), 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 = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

A Worksheet Change: Time Stamp and Clear
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const fRow As Long = 1 ' possibly 2 or more to exclude headers
Const cOffset As Long = 1
' Reference the intersecting range.
Dim irg As Range ' Intersect
With Columns("B")
With .Resize(.Rows.Count - fRow + 1).Offset(fRow - 1)
'Debug.Print Union(.Cells, .EntireRow.Columns("D")).Address
Set irg = Intersect(Union(.Cells, .EntireRow.Columns("D")), Target)
End With
End With
If irg Is Nothing Then Exit Sub
Dim trg As Range ' Time
Dim crg As Range ' Clear
Dim iCell As Range
' Combine cells into the Time and Clear ranges.
For Each iCell In irg.Cells
If Not VBA.IsEmpty(iCell.Value) Then
If trg Is Nothing Then Set trg = iCell _
Else Set trg = Union(trg, iCell)
Else
If crg Is Nothing Then Set crg = iCell _
Else Set crg = Union(crg, iCell)
End If
Next iCell
Application.EnableEvents = False
' Write.
If Not trg Is Nothing Then
With trg.Offset(, cOffset)
.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
.Value = Now
End With
End If
If Not crg Is Nothing Then
crg.Offset(, cOffset).ClearContents
End If
Application.EnableEvents = True
End Sub

Excel Record Date And Time Automatically When Cell Changes VBA

I am using the following VBA code to automatically timestamp dates when I edit or change cells. It works perfectly however, whenever i delete a row it will cause the cell directly under it to refresh its timestamp, this is very annoying and has led me to hide unwanted rows instead of deleting them, appreciate if you can help me fix this through changes in the VBA.
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("B:B"), 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 = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

You can ignore changes which involve a whole row or rows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range, c As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
'whole row(s) changed - do not process
If Target.Columns.Count = Me.Columns.Count Then Exit Sub
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
Set c = Rng.Offset(0, xOffsetColumn) '****
If Not VBA.IsEmpty(Rng.Value) Then
c.Value = Now
c.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
c.ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

Generate datetime when entry made in cell

I have code which should display the date in column A whenever something is entered in column B.
I enabled macros in security settings.
The VBA code is in ThisWorkbook under the project because I want the same thing to happen on every sheet.
Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Source As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), 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 = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

A couple of changes:
1) First, you need(ed) to change to the workbook level event: the Workbook.SheetChange event.
2) Then change Application.ActiveSheet to Sh.
3) Make sure that the parameter is named Target if you're using Target within the code body.
4) Add some error handling to make sure events always get re-enabled:
Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Sh.Range("B:B"), Target)
xOffsetColumn = -1
If Not WorkRng Is Nothing Then
On Error GoTo SafeExit
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 = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
End If
SafeExit:
Application.EnableEvents = True
End Sub

Something for you to consider (if you desire so) is to catch Now before you Loop to prevent different values. In such case you might not even want a loop at all. Consider to replace:
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
With:
'Non empty cells with constants
If Application.CountA(WorkRng) > 0 Then
Set Rng = WorkRng.SpecialCells(xlCellTypeConstants).Offset(0, -1)
Rng.Value = Now
Rng.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End If
And:
'Empty Cells
If Application.CountBlank(WorkRng) > 0 Then
WorkRng.SpecialCells(xlCellTypeBlanks).Offset(0, -1).ClearContents
End If
You could implement this within the answer given by #BigBen if you will.

vba FOR to validate color of cells in a range

I am doing a macro to check and validate all cells by colorindex. kindly help me if there is wrong in my code. Many Thanks.
Sub Validate()
Dim rng As Range: Set rng = Application.Range("CATALOG!B2:F98")
Dim cel As Range
Dim i As Boolean
i = False
For Each cel In rng
With cel
If .Interior.ColorIndex = 6 Then
If .EntireRow.Hidden = False Then
i = True
End If
End If
End With
Next cel
If i = True Then
MsgBox "yellow"
Else
MsgBox "none"
End If
End Sub

It's pretty unclear what you're asking, but there are two ways:
1) first, when you want to check if every cell in range has .Interior.ColorIndex = 6. Then your code should look like:
Sub Validate()
Dim rng As Range: Set rng = Application.Range("CATALOG!B2:F98")
Dim cel As Range
Dim i As Boolean
i = True
For Each cel In rng.Cells
If Not cel.Interior.ColorIndex = 6 Then
i = False
Exit For 'we found cell with different color, so we can exit loop
End If
Next cel
If i = True Then
MsgBox "yellow"
Else
MsgBox "none"
End If
End Sub
2) you want to check if any cell has .Interior.ColorIndex = 6. Then it should look like:
Sub Validate()
Dim rng As Range: Set rng = Application.Range("CATALOG!B2:F98")
Dim cel As Range
Dim i As Boolean
i = False
For Each cel In rng.Cells
If cel.Interior.ColorIndex = 6 Then
i = True
Exit For 'we found cell with the color, so we can exit loop
End If
Next cel
If i = True Then
MsgBox "yellow"
Else
MsgBox "none"
End If
End Sub

Of what I've gatered you are trying to loop through all non hidden cells and see if they have a yellow background color, and if they are yellow they need to change based on a input.
Sub Validate()
Dim rng As Range: Set rng = Application.Range("CATALOG!B1:F98")
Dim cel As Range
For Each cel In rng
With cel
If .Interior.ColorIndex = 6 Then
If .EntireRow.Hidden = False Then
.Interior.ColorIndex = InputBox("please input new colorIndex", "SetColorIndex")
End If
End If
End With
Next cel
End Sub

Resources