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

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

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

13 Replies

HansVogelaar

MVP

Feb 16, 2021

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

Change99

Brass Contributor

Feb 16, 2021

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)

HansVogelaar

MVP

Feb 16, 2021

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

Forum Discussion

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

13 Replies

Resources