Feb 16 2021 04:43 AM - edited Feb 18 2021 11:18 PM
I would like to have Excel copy the changed values of one cell to multiple columns on a another sheet.
1) B2 has a value. I change the value. It copies the value to sheet 2. I then change the value on sheet 1 again. It again copies the value onto sheet 2 (to column B) but it doesn't overwrite it, it just populates the next row number over.
2) B3 has a value and should be saved as above, but this time on column C (sheet2). etc...
On a diffrent blog this works but only for 1)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
a = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Sheet2").Range("A" & a).Value = Sheets("Sheet1").Range("B2").Value
End If
End Sub
Feb 16 2021 05:19 AM
SolutionLike 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
Feb 16 2021 06:00 AM - edited Feb 18 2021 11:27 PM
@Hans VogelaarThank 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)
Feb 16 2021 06:16 AM
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 Sub
Feb 16 2021 11:19 PM
@Hans Vogelaarthank you again works perfectly!
Feb 18 2021 01:36 AM - edited Feb 18 2021 01:36 AM
@Hans VogelaarIs 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. :)
Feb 18 2021 02:54 AM
The two parts now perform slightly different actions. What would you like to repeat?
Feb 18 2021 03:01 AM - edited Feb 18 2021 03:12 AM
@Hans VogelaarOh 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.
Feb 18 2021 03:55 AM
In the worksheet module:
Private Sub Worksheet_Change(ByVal Target As Range)
HandleChange Target, "P", Worksheets("Sheet2")
HandleChange Target, "L", Worksheets("Sheet3")
HandleChange Target, "F", Worksheets("Sheet4")
'...
End Sub
Private Sub HandleChange(Target As Range, Col As String, Sht As Worksheet)
Dim rng 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
Set rng = Columns(Col)
Set rng = rng.Resize(rng.Cells.Count - 1).Offset(1)
If Not Intersect(rng, Target) Is Nothing Then
For Each rng1 In Intersect(rng, Target)
c = 2 * rng1.Row - 2
With Sht
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 Sub
You can modify/expand Worksheet_Change as needed.
Feb 18 2021 06:57 AM - edited Feb 18 2021 11:21 PM
@Hans VogelaarWorks great on its own! Thanks! The only problem I am having is to integrate it with the other code. Any pointers?
Last time I combined it like this:
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
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("P2:P" & Rows.Count), Target) Is Nothing Then
For Each rng1 In Intersect(Range("P2:P" & Rows.Count), Target)
c = 2 * rng1.Row - 2
With Worksheets("Tabelle2")
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 Sub
Feb 18 2021 07:09 AM
Please use the </> button to post code - it preserves indentation.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim r As Long
On Error GoTo ErrHandler
Application.ScreenUpdating = False
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
HandleChange Target, "P", Worksheets("Sheet2")
HandleChange Target, "L", Worksheets("Sheet3")
HandleChange Target, "F", Worksheets("Sheet4")
'...
ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Private Sub HandleChange(Target As Range, Col As String, Sht As Worksheet)
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim r As Long
Dim c As Long
Set rng = Columns(Col)
Set rng = rng.Resize(rng.Cells.Count - 1).Offset(1)
If Not Intersect(rng, Target) Is Nothing Then
For Each rng1 In Intersect(rng, Target)
c = 2 * rng1.Row - 2
With Sht
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
End Sub
Feb 19 2021 12:45 AM
@Hans VogelaarThanks again!
Feb 22 2021 11:31 PM
@Hans VogelaarIs it possible to leave one column free on the sheets where the entry and entry time are copied to?
Like this
input on P2 -> output B2 (2nd sheet) + date of entry on C2
input on P3 -> output on E2 (2nd sheet) + date of entry on F2
I am asking because I want to integrate the timeline I found (http://www.surtenexcel.com/2012/analysis/10/02/dynamic-timeline-chart/ ) so that it automatically creates a timeline.
Thank you for your help so far! I don't expect you to solve this one but here it is: Only problem I am having with this method so far is the following. I am using this for clients. So if I input for example:
Client X on row 2 (sheet1) : input on P2 -> output B2 (2nd sheet) + date of entry on C2
Problem arise If client X would change row. Therefore when new clients join I cant alphabetically sort them on sheet 1.
Feb 23 2021 03:14 AM
Edit HandleChange as follows:
Private Sub HandleChange(Target As Range, Col As String, Sht As Worksheet)
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim r As Long
Dim c As Long
Set rng = Columns(Col)
Set rng = rng.Resize(rng.Cells.Count - 1).Offset(1)
If Not Intersect(rng, Target) Is Nothing Then
For Each rng1 In Intersect(rng, Target)
c = 3 * rng1.Row - 5
With Sht
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
End Sub
Feb 16 2021 05:19 AM
SolutionLike 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