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
HansVogelaarWorks 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 SubPlease 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 SubEdit 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 SubHansVogelaarIs 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.
HansVogelaarThanks again!