Forum Discussion
When cell value changes, copy the information to a new worksheet to multiple columns
Like this:
Private Sub Worksheet_Change(ByVal Target As Range) Dim rng1 As Range Dim rng2 As Range Dim c As Long If Intersect(Range("B2:B" & Rows.Count), Target) Is Nothing Then Exit Sub End If On Error GoTo ErrHandler Application.EnableEvents = False For Each rng1 In Intersect(Range("B2:B" & Rows.Count), Target) c = rng1.Row With Worksheets("Sheet 2") Set rng2 = .Cells(.Rows.Count, c).End(xlUp).Offset(1) End With rng2.Value = rng1.Value Next rng1 ExitHandler: Application.EnableEvents = True Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation Resume ExitHandler End Sub
HansVogelaarThank you so much! I would have two more questions if you would be so kind. First one is more important but I would read both before answering because they probably interact.
1) How to combine your code with the following which is already running in my worksheet (since as I understand only 1 change event can be made):
Private Sub Worksheet_Change(ByVal Target As Range)
'Timestamp Data
' TeachExcel.com
Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range
'Your data table range
Set myTableRange = Range("K2:P500")
'Check if the changed cell is in the data tabe or not.
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub
'Stop events from running
Application.EnableEvents = False
'Column for the date/time
Set myDateTimeRange = Range("X" & Target.Row)
'Column for last updated date/time
Set myUpdatedRange = Range("Y" & Target.Row)
'Determine if the input date/time should change
If myDateTimeRange.Value = "" Then
myDateTimeRange.Value = Now
End If
'Update the updated date/time value
myUpdatedRange.Value = Now
'Turn events back on
Application.EnableEvents = True
End Sub
2) Could you change your code so that it does the following:
In addition to output the changes in the second worksheet it would be awesome if it could output the date of when the entry was changed. For example (I am using the P column):
input on P2 -> output B2 (2nd sheet) + date of entry on C2
input on P3 -> output on D2 (2nd sheet) + date of entry on E2
Maybe the code from 1) could be also changed for 2)
Here is an updated version:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Dim r As Long
Dim c As Long
On Error GoTo ErrHandler
Application.EnableEvents = False
'Check if the changed cell is in the data table or not.
If Not Intersect(Range("K2:P500"), Target) Is Nothing Then
For Each rng1 In Intersect(Range("K2:P500"), Target)
r = rng1.Row
'Determine if the input date/time should change
If Range("X" & r).Value = "" Then
Range("X" & r).Value = Now
End If
'Update the update date/time value
Range("Y" & r).Value = Now
Next rng1
End If
If Not Intersect(Range("B2:B" & Rows.Count), Target) Is Nothing Then
For Each rng1 In Intersect(Range("B2:B" & Rows.Count), Target)
c = 2 * rng1.Row - 2
With Worksheets("Sheet 2")
Set rng2 = .Cells(.Rows.Count, c + 1).End(xlUp).Offset(1)
End With
rng2.Value = rng1.Value
rng2.Offset(0, 1).Value = Now
Next rng1
End If
ExitHandler:
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End SubHansVogelaarIs it possible to use this code multiple times? For example the same procedure just for column L. Results would be saved on sheet3. You are improving the workflow of someone that works in youth work. 🙂
The two parts now perform slightly different actions. What would you like to repeat?
HansVogelaarOh okay! The part where it copies the entry and adds it with the entry time.
Example:
input on P2 (sheet1) -> output B2 (2nd sheet) + date of entry on C2
input on P3 (sheet1)-> output on D2 (2nd sheet) + date of entry on E2
input on L2 (sheet1) -> output B2 (3rd sheet) + date of entry on C2
input on L3 (sheet1) -> output on D2 (3rd sheet) + date of entry on E2
...
If possible I would like to choose on how many and which columns of sheet1 this applies and to which sheet the output and entry times are saved.
HansVogelaarthank you again works perfectly!