Print Date and time in fixed column instead offset for Log of events - excel

I´d like to create a log of events. With a form I´ll fill cells on the same row starting in column C and I´d like date and time printed automatically in columns A and B. Sometimes information might start from column D and C would be empty.
The code below does that through an offset from column C and C only. Even if I expand the range for Intersect, the date and time will be carried out and not stay fixed in A and B. Does anyone would have a hint for me?
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rCell As Range
Dim rChange As Range
On Error GoTo ErrHandler
Set rChange = Intersect(Target, Range("C:C"))
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
With rCell.Offset(0, -2)
.Value = Date
.NumberFormat = "[$-2C09]ddd, DD/MM/YYYY"
.HorizontalAlignment = xlLeft
.EntireColumn.AutoFit
End With
With rCell.Offset(0, -1)
.Value = Time
.NumberFormat = "hh:mm"
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
Else
rCell.Offset(0, -1).Clear
rCell.Offset(0, -2).Clear
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

Dim rw as Range
'.......
'.......
If rCell > "" Then
Set rw = rCell.EntireRow
With rw.Cells(1)
.Value = Date
.NumberFormat = "[$-2C09]ddd, DD/MM/YYYY"
.HorizontalAlignment = xlLeft
.EntireColumn.AutoFit
End With
With With rw.Cells(2)
.Value = Time
.NumberFormat = "hh:mm"
.HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
Else
rCell.EntireRow.Cells(1).Resize(1,2).Clear
End If
'.......

Related

Excel VBA dual Worksheet_change events not working

Having trouble executing both Worksheet_Change events correctly. Image below show my results, when modifying column B, column M does nothing. When modifying column L, column N updates as expected but only on row 2. Every other subsequent change to B or M results in N:2 updating to the current time again.
My desired outcome is that when Col B is updated I record a time stamp in Col M and the same when Col L updates that I get a time stamp in Col N.
Example of Excel Error
My current code is here:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim rng As Range
Dim rng2 As Range
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
Application.EnableEvents = True
End If
ElseIf Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng2 In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng2.Value2)) And Not CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng2.Value2)) And CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = vbNullString
End If
Next rng2
Application.EnableEvents = True
End If
Safe_Exit:
End Sub
Mock-up, untested, change of code to simplify as you're doing the same actions in two spots:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim columnLetter as String
Select Case Target.Column
Case 2 'B
columnLetter = "M"
Case 12 'L
columnLetter = "N"
Case Else
Goto Safe_Exit
End Select
Dim loopRng as Range
For Each loopRng In Range(Cells(Target.Row, Target.Column),Cells(Target.End(xlDown).Row,Target.Column)
If IsEmpty(loopRng) = True And IsEmpty(Cells(loopRng.Row,columnLetter)) = False Then
Cells(loopRng.Row,columnLetter) = Now
ElseIf IsEmpty(loopRng) = False And IsEmpty(Cells(loopRng.Row,columnLetter)) = True Then
Cells(loopRng.Row,columnLetter) = vbNullString
End If
Next loopRng
'Columns(columnLetter).NumberFormat = "yyyy/mm/dd"
Application.EnableEvents = True
Safe_Exit:
Application.EnableEvents = True
End Sub
Note that the IsEmpty() = True is important... when using an If case, you need to specify for each condition, otherwise the implicit detection will fail.
Edit1: Removed Intersect from loop, whereas the range i've listed will need corrected... it at least references a specific range, now.
Edit2: Removing .Offset and working with specific column references in cells().
I tried this version of my original code and it started to work for some reason.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
End If
If Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
For Each rng In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = vbNullString
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub

How to solve the VBA error invalid inside procedure

I am currently trying to run this VBA code and keep getting the repeated error 'Invalid inside procedure'. Could anyone suggest what part of the code is wrong?
I have attempted to fault find however can not seem to find the root of the problem.
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("C:C"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("G:G"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 12).ClearContents
Else
With .Offset(0, 12)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
Option Explicit
Const sCell As String = "G2" ' Source First Cell
Const dCol As Variant = "J" ' Destination Column Id (String or Index)
Dim irg As Range ' Intersect Range
Dim cOffset As Long ' Column Offset
With Range(sCell)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
If irg Is Nothing Then Exit Sub
cOffset = Columns(dCol).Column - .Column
End With
Dim arg As Range ' Current Area of Intersect Range
Dim cel As Range ' Current Cell in Current Area of Intersect Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If Not IsError(cel.Value) Then
cel.Offset(, cOffset).Value = cel.Value
End If
Next cel
Next arg
End Sub ```
Try to declare Option Explicit before any procedure -- not within it.

Is there a function that deletes a cells value if I delete the value of another cell in the same row?

I'm currently setting up a small inventory tool and since I'm new to vba I got stuck.
So I got a table where you can register all the ingoing and outgoing goods and so far I've included a macro which automatically puts the date into the row if the cells in the ingoing and outgoing columns are changed.
What I want to do now is that if I delete a value in the outgoing/ingoing columns the date will disappear too.
That's my code so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
On Error GoTo Ende
Application.EnableEvents = False
For Each rng In Application.Intersect(Columns("D"), Target).Cells
If rng.Offset(0, -2).Value = "" Then
rng.Offset(0, -2).Value = Date
End If
Next rng
Ende:
Application.EnableEvents = True
End Sub
Anyone got an idea?
Quck and dirty fix - add another for loop that checks if the target cell is empty:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
On Error GoTo Ende
Application.EnableEvents = False
For Each rng In Application.Intersect(Columns("D"), Target).Cells
If rng.Offset(0, -2).Value = "" Then
rng.Offset(0, -2).Value = Date
End If
Next rng
For Each rng In Application.Intersect(Columns("D"), Target).Cells
If rng = "" Then
rng.Offset(0, -2).Value = ""
End If
Next rng
Ende:
Application.EnableEvents = True
End Sub

Conditional highlighting: How to optimise?

I have code which achieves exactly what I want. The basis of my code comes from the generous help of Tim Williams in a previous question. Building on his help, I have added slightly to the functionality (larger font size, and returning formatting to original if nothing in the column is selected), and extended the code across several columns, as shown in the code.
The problem is my spreadsheet is now intolerably slow. Is there a way to speed things up?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range, c As Range
'Set target for all columns that have this functionality
Set r = Intersect(Me.Range("N:Q"), Target)
'The functionality is repeated for several columns and is identical each time (except for N which maps to two columns)
'Column N maps to columns H & I
If Not Application.Intersect(Target, Range("N:N")) Is Nothing Then
If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub
Application.ScreenUpdating = False
HighlightIt Application.Intersect(Me.Range("H:I"), Me.UsedRange), False
For Each c In r.Cells
HighlightIt Me.Cells(c.Row, "H").Resize(1, 2)
Next c
Else
With Application.Intersect(Me.Range("H:I"), Me.UsedRange)
.Font.Bold = False
.Font.Color = vbBlack
.Font.Size = 14
End With
End If
'Column O maps to columns J
If Not Application.Intersect(Target, Range("O:O")) Is Nothing Then
If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub
Application.ScreenUpdating = False
HighlightIt Application.Intersect(Me.Range("J:J"), Me.UsedRange), False
For Each c In r.Cells
HighlightIt Me.Cells(c.Row, "J")
Next c
Else
With Application.Intersect(Me.Range("J:J"), Me.UsedRange)
.Font.Bold = False
.Font.Color = vbBlack
.Font.Size = 14
End With
End If
'Column P maps to columns K
If Not Application.Intersect(Target, Range("P:P")) Is Nothing Then
If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub
Application.ScreenUpdating = False
HighlightIt Application.Intersect(Me.Range("K:K"), Me.UsedRange), False
For Each c In r.Cells
HighlightIt Me.Cells(c.Row, "K")
Next c
Else
With Application.Intersect(Me.Range("K:K"), Me.UsedRange)
.Font.Bold = False
.Font.Color = vbBlack
.Font.Size = 14
End With
End If
'Column Q maps to columns L
If Not Application.Intersect(Target, Range("Q:Q")) Is Nothing Then
If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub
Application.ScreenUpdating = False
HighlightIt Application.Intersect(Me.Range("L:L"), Me.UsedRange), False
For Each c In r.Cells
HighlightIt Me.Cells(c.Row, "L")
Next c
Else
With Application.Intersect(Me.Range("L:L"), Me.UsedRange)
.Font.Bold = False
.Font.Color = vbBlack
.Font.Size = 14
End With
End If
End Sub
'utility sub for highlighting/unhighlighting
Sub HighlightIt(rng As Range, Optional hilite As Boolean = True)
With rng
.Font.Color = IIf(hilite, vbWhite, vbBlack)
.Font.Bold = hilite
.Font.Size = IIf(hilite, 20, 14)
End With
End Sub
Darren Bartrup is right. Code Review is an excellent site to obtain help on making your code more efficient.
I'm providing an answer as I'm not sure you've quite got the spirit of Tim Williams' answer. As well as not needing to iterate the cells, you should also be able to do without identical code for each tested column. You can do this by creating some form of selected column to highlight column map. Below is skeleton code to get you started.
The code you've supplied shouldn't be as slow as you are describing, so I wonder if you're handling other events (or there's more code in your _Select event). If there is, then make sure you include it in your question on Code Review or here.
Option Explicit
Private mColumnMap As Collection
Private mOldRange As Range
Private mOldCellColour As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim mappedRange As Range
Dim mappedCells As Range
'Define the column map.
If mColumnMap Is Nothing Then
Set mColumnMap = New Collection
mColumnMap.Add Me.Range("H:I"), "14" 'N
mColumnMap.Add Me.Range("J:J"), "15" 'O
mColumnMap.Add Me.Range("K:K"), "16" 'P
mColumnMap.Add Me.Range("L:L"), "17" 'Q
End If
'If there is a highlighted range, change it back.
If Not mOldRange Is Nothing Then
With mOldRange
.Interior.Color = mOldCellColour
.Font.Bold = False
End With
Set mOldRange = Nothing
End If
'Ignore any selections that are more than one column.
If Target.Columns.Count <> 1 Then Exit Sub
'Ignore any selections outside of a specified range.
'Note: I've just used the 'UsedRange'.
If Intersect(Target, Me.UsedRange) Is Nothing Then Exit Sub
'Acquire the appropriate column map.
On Error Resume Next
Set mappedRange = mColumnMap(CStr(Target.Column))
On Error GoTo 0
'Exit if not a target column.
If mappedRange Is Nothing Then Exit Sub
'Define the cells to be changed.
Set mappedCells = Intersect(mappedRange, Target.EntireRow)
'Store the original values.
Set mOldRange = mappedCells
mOldCellColour = mappedCells(1).Interior.Color
'Change the values.
Application.ScreenUpdating = False
With mappedCells
.Interior.Color = vbWhite
.Font.Bold = True
End With
Application.ScreenUpdating = True
End Sub

Two time stamp codes working at the same time?

I need help writing a code that will allow for a date/ time stamp in column H when there is any value entered in I. Right now the code below allows for a time-stamp in G, when a value is entered in column B. What do I need to do?
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rCell As Range
Dim rChange As Range
On Error GoTo ErrHandler
Set rChange = Intersect(Target, Range("B:B"))
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
With rCell.Offset(0, 5)
.Value = Now
.NumberFormat = "mm-dd-yy h:mm AM/PM"
End With
Else
rCell.Offset(0, 5).Clear
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
You could either add an ElseIf for a second range or include I:I in the primary check for an intersect and decide where to stuff the timestamp depending on whether it was B:B or I:I that received the addition/deletion/modification. I'll demonstrate the latter.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rCell As Range
Dim rChange As Range
On Error GoTo ErrHandler
Set rChange = Intersect(Target, Range("B:B, I:I")) '<- note change
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
With rCell.Offset(0, 5 + (rCell.Column = 9) * 6) '<- note change
.Value = Now
.NumberFormat = "mm-dd-yy h:mm AM/PM"
End With
Else
rCell.Offset(0, 5 + (rCell.Column = 9) * 6).Clear '<- note change
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
I've added I:I to the check for intersect and used VBA's True = (-1) to adjust which column receives the timestamp.

Resources