SOLVED

When cell value changes, copy the information to a new worksheet to multiple columns

Brass Contributor

 

 

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
13 Replies
best response confirmed by Change99 (Brass Contributor)
Solution

@Change99 

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

@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)

 

 

@Change99 

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

@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. :)

@Change99 

The two parts now perform slightly different actions. What would you like to repeat?

@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.

 

@Change99 

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.

@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

@Change99 

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

@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.

 

@Change99 

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
1 best response

Accepted Solutions
best response confirmed by Change99 (Brass Contributor)
Solution

@Change99 

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

View solution in original post