Copy specific range of cells on a change event then paste to a new row in a another sheet

[lizpcon]

I hope someone can provide me with some help. I realize there are many variations on this question, but I am not finding an answer that suits my needs. My expertise with VBA is basically restricted to finding code in posts that does what I need. I am definitely a beginner when it comes to code.

Essentially I need to copy the first 8 cells in a row in one sheet (for example: A3:I3) when the word "Actuals" is entered into A3 from a drop down list. Then the copied data needs to be pasted to a another existing worksheet in the same workbook in the next available row. The data includes mostly values, but there is a formula in column H that creates a hyperlink out of the content in column G, friendly name in column I.

I am not stuck on the idea of having "Actuals" entered in column A as the trigger or change event and there will be times when a new copy/paste of the same data will need to be done more than once at a later date.

For further information, column B contains a serial number/productID number.

Thanks,

Lizpcon

 

[JoeMo]

This should do what you want including the time stamp.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nR As Long
Set Target = Target.Cells(1, 1)
If Not Intersect(Target, Range("Q:T")) Is Nothing Then 
     Range("V" & Target.Row).Value = Now
     Exit Sub
End If
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    If Target.Value = ("Actuals") Then
        nR = WorksheetFunction.Max(2, Sheets("PubCostTracking").Range("A" & Rows.Count).End(xlUp).Row + 1)
        Range(Target, Target.Offset(0, 6)).Copy
        Sheets("PubCostTracking").Range("A" & nR).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
        Range(Target.Offset(0, 7), Target.Offset(0, 9)).Copy
        Sheets("PubCostTracking").Range("H" & nR).PasteSpecial Paste:=xlFormulas
        Application.CutCopyMode = False
    End If
End If
Application.ScreenUpdating = False
 Sheets("PubCostTracking").Select
Activesheet.Range("K" & nR).select
End Sub

 

[JoeMo]

This should do what you want including the time stamp.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nR As Long
Set Target = Target.Cells(1, 1)
If Not Intersect(Target, Range("Q:T")) Is Nothing Then 
     Range("V" & Target.Row).Value = Now
     Exit Sub
End If
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    If Target.Value = ("Actuals") Then
        nR = WorksheetFunction.Max(2, Sheets("PubCostTracking").Range("A" & Rows.Count).End(xlUp).Row + 1)
        Range(Target, Target.Offset(0, 6)).Copy
        Sheets("PubCostTracking").Range("A" & nR).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
        Range(Target.Offset(0, 7), Target.Offset(0, 9)).Copy
        Sheets("PubCostTracking").Range("H" & nR).PasteSpecial Paste:=xlFormulas
        Application.CutCopyMode = False
    End If
End If
Application.ScreenUpdating = False
 Sheets("PubCostTracking").Select
Activesheet.Range("K" & nR).select
End Sub

Sorry, there's an error in the code above. Use this instead.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nR As Long
Set Target = Target.Cells(1, 1)
If Not Intersect(Target, Range("Q:T")) Is Nothing Then
     Range("V" & Target.Row).Value = Now
     Exit Sub
End If
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    If Target.Value = ("Actuals") Then
        nR = WorksheetFunction.Max(2, Sheets("PubCostTracking").Range("A" & Rows.Count).End(xlUp).Row + 1)
        Range(Target, Target.Offset(0, 6)).Copy
        Sheets("PubCostTracking").Range("A" & nR).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
        Range(Target.Offset(0, 7), Target.Offset(0, 9)).Copy
        Sheets("PubCostTracking").Range("H" & nR).PasteSpecial Paste:=xlFormulas
        Application.CutCopyMode = False
        Application.ScreenUpdating = False
        Sheets("PubCostTracking").Select
        ActiveSheet.Range("K" & nR).Select
    End If
End If
End Sub

 

[lizpcon]

Hi, I've encountered an issue as a result of adding the destination sheet code to the end. It now goes to the destination sheet any time I enter anything on the starting sheet. It doesn't copy, just goes to the destination sheet (PubCostTracking)...

So, I moved the destination statement to before the End If. It works now, but now I have another problem. Is there a way that the copy paste can work with hidden rows? (Two of the formulas that I want to keep are in hidden rows.) I suppose a work around would be to make the rows narrow and the text white and lock the cells...

 

[lizpcon]

Not sure why, but without changing anything the hidden rows are no longer a problem. Just testing the file -- the file seems to take an awfully long time to save. Is that normal?? Thanks again.

 

[JoeMo]

Not sure why, but without changing anything the hidden rows are no longer a problem. Just testing the file -- the file seems to take an awfully long time to save. Is that normal?? Thanks again.

You should use the code in Post #12 not Post #11. There's no reason that addition of this code would increase the time it takes to save the file. Excel usually calculates on save. If you have lots of calculations this might be impacting the save time.

 

[lizpcon]

Thanks so much Joe, I did use the code in #12, I've even been able to modify it (changed the order of some rows, that sort of thing), and added a message box before it creates the new row in the destination sheet. This is what I ended up with and it seems to do the job.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nR As Long
Set Target = Target.Cells(1, 1)
If Not Intersect(Target, Range("Q:T")) Is Nothing Then
Range("V" & Target.Row).Value = Now
Exit Sub
End If
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target.Value = ("Actuals") Then
Dim Response As VbMsgBoxResult
Response = MsgBox("Do you want to create a new cost tracking row?", vbQuestion + vbYesNo, "Create nre row?")
If Response = vbNo Then Exit Sub

Application.ScreenUpdating = False
nR = WorksheetFunction.Max(2, Sheets("PubCostTracking").Range("A" & Rows.Count).End(xlUp).Row + 1)
Range(Target, Target.Offset(0, 8)).Copy
Sheets("PubCostTracking").Range("A" & nR).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Range(Target.Offset(0, 9), Target.Offset(0, 11)).Copy
Sheets("PubCostTracking").Range("I" & nR).PasteSpecial Paste:=xlFormulas
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("PubCostTracking").Select
ActiveSheet.Range("M" & nR).Select
End If
End If
End Sub


Thanks again for your help!

 

[JoeMo]

Thanks so much Joe, I did use the code in #12, I've even been able to modify it (changed the order of some rows, that sort of thing), and added a message box before it creates the new row in the destination sheet. This is what I ended up with and it seems to do the job.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim nR As Long
Set Target = Target.Cells(1, 1)
If Not Intersect(Target, Range("Q:T")) Is Nothing Then
Range("V" & Target.Row).Value = Now
Exit Sub
End If
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target.Value = ("Actuals") Then
Dim Response As VbMsgBoxResult
Response = MsgBox("Do you want to create a new cost tracking row?", vbQuestion + vbYesNo, "Create nre row?")
If Response = vbNo Then Exit Sub

Application.ScreenUpdating = False
nR = WorksheetFunction.Max(2, Sheets("PubCostTracking").Range("A" & Rows.Count).End(xlUp).Row + 1)
Range(Target, Target.Offset(0, 8)).Copy
Sheets("PubCostTracking").Range("A" & nR).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Range(Target.Offset(0, 9), Target.Offset(0, 11)).Copy
Sheets("PubCostTracking").Range("I" & nR).PasteSpecial Paste:=xlFormulas
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("PubCostTracking").Select
ActiveSheet.Range("M" & nR).Select
End If
End If
End Sub


Thanks again for your help!

You are welcome. Thanks for the reply.

 

[lizpcon]

Hi,

I'm not sure if it appropriate for me to re-open this question, but I have an issue with the code not copying and pasting correctly if some rows are hidden -- which I want them to be -- and if some columns are filtered, which they will often be when this file is in use. Can you suggest code I should add to the below to unfilter all columns prior to copying and return the filtered state after pasting? Thanks,



Private Sub Worksheet_Change(ByVal Target As Range)
Dim nR As Long
Set Target = Target.Cells(1, 1)
If Not Intersect(Target, Range("X:AD")) Is Nothing Then
Range("AE" & Target.Row).Value = Now
Exit Sub
End If
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target.Value = ("Actuals") Then
Dim Response As VbMsgBoxResult
Response = MsgBox("Do you want to create a new cost tracking row?", vbQuestion + vbYesNo, "Create nre row?")
If Response = vbNo Then Exit Sub
Application.ScreenUpdating = False
nR = WorksheetFunction.Max(2, Sheets("PubCostTracking").Range("A" & Rows.Count).End(xlUp).Row + 1)
Range(Target, Target.Offset(0, 7)).Copy
Sheets("PubCostTracking").Range("A" & nR).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Range(Target.Offset(0, 8), Target.Offset(0, 10)).Copy
Sheets("PubCostTracking").Range("I" & nR).PasteSpecial Paste:=xlFormulas
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("PubCostTracking").Select
ActiveSheet.Range("M" & nR).Select
End If
End If
End Sub

 

[JoeMo]

Here's a link to a module that will determine the autofilter state, remove the autofilter to allow your code to copy/paste and then restore the autofilter to its original state. You can adapt this to your existing code.
In Excel VBA, how do I save / restore a user-defined filter? - Stack Overflow