Macro to copy cells in sh 2 triggered by an entry in one of them and pasted in sh1 into a row with same log no.

[Raceman]

Hello: can someone help me with VBA Code to do the following:

On Sheet 2, after an entry is made in Cell P an event is triggered that will copy cells P and Q (in the same row) only if Cell C in that row = "Task Summary" (note on sheet 2 there is a log no. in cell A)

then on Sheet 1 this info will be pasted into cells Y and Z (and the row with the same Log No.as on Sheet 2) .

Log No., which is a three digit no. starting with 001, is in Column A on both Sheet 1 and 2.

Not sure where to even start on this one​

 

[JLGWhiz]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fVal As Range
If Not Intersect(Target, Range("P:P")) Is Nothing Then
    Set fVal = Sheets("Sheet1").Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues)
        If Not fVal Is Nothing Then
            Target.Resize(1, 2).Copy Sheets("Sheet1").Range("Y" & fVal.Row)
        End If
End If
End Sub

 

[Raceman]

Hi: JLGWhiz : Thanks much your code works great when I disable other code on that Worksheet. I'm obviously new at this and don't quite understand how to integrate your code with an existing Private Sub Worksheet_Change on the same Worksheet. Especially not sure how to relate Dim fVBal As Range with my existing code, but as shown below, the code stops with an error when I attempt to get my automatic date (from my code), the error says, ""Compile error: End If without block If".

'This will automatically provide dates where appropriate
Private Sub Worksheet_Change(ByVal Target As Range)
Set t = Target
Set dd = Range("$D$3:$D$5000")
Set ff = Range("$F$3:$F$5000")
Set hh = Range("$H$3:$H$5000")
Set jj = Range("$J$3:$J$5000")
Set ll = Range("$L$3:$L$5000")
Set nn = Range("$N$3:$N$5000")
Set pp = Range("$P$3:$P$5000")
If Target.Count > 1 Then Exit Sub
If (Intersect(t, dd) Is Nothing) And (Intersect(t, ff) Is Nothing) And (Intersect(t, dd) Is Nothing) And (Intersect(t, hh) Is Nothing) And (Intersect(t, jj) Is Nothing) And (Intersect(t, ll) Is Nothing) And (Intersect(t, nn) Is Nothing) And (Intersect(t, pp) Is Nothing) Then Exit Sub
Application.EnableEvents = False
t.Offset(0, 1).Value = Date
Application.EnableEvents = True
End If
'This code provided by JLGWhiz automatically moves data from cells P and Q to Sheet 1
Dim fVal As Range
If Not Intersect(Target, Range("P:P")) Is Nothing Then
Set fVal = Sheets("Sheet1").Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues)
If Not fVal Is Nothing Then
Target.Resize(1, 2).Copy Sheets("Sheet1").Range("Y" & fVal.Row)
End If
End If
End Sub

 

[Raceman]

Hi JLGWhiz: I got it working- I removed the "End If" between our codes and then it worked. Very cool....thanks so much for your help!

 

[Raceman]

Oh I just realized....your code does the auto copy and paste for every row on sh2, if possible, I needed this macro to be triggered only in rows where Cell C in that row = "Task Summary"

 

[JLGWhiz]

Oh I just realized....your code does the auto copy and paste for every row on sh2, if possible, I needed this macro to be triggered only in rows where Cell C in that row = "Task Summary"

Modified.

Private Sub Worksheet_Change(ByVal Target As Range)
Set t = Target
Set dd = Range("$D$3:$D$5000")
Set ff = Range("$F$3:$F$5000")
Set hh = Range("$H$3:$H$5000")
Set jj = Range("$J$3:$J$5000")
Set ll = Range("$L$3:$L$5000")
Set nn = Range("$N$3:$N$5000")
Set pp = Range("$P$3:$P$5000")
If Target.Count > 1 Then Exit Sub
If (Intersect(t, dd) Is Nothing) And (Intersect(t, ff) Is Nothing) And (Intersect(t, dd) Is Nothing) _
And (Intersect(t, hh) Is Nothing) And (Intersect(t, jj) Is Nothing) And (Intersect(t, ll) Is Nothing) _
And (Intersect(t, nn) Is Nothing) And (Intersect(t, pp) Is Nothing) Then Exit Sub
Application.EnableEvents = False
t.Offset(0, 1).Value = Date
Application.EnableEvents = True
    'This code provided by JLGWhiz automatically moves data from cells P and Q to Sheet 1
    Dim fVal As Range
    If Not Intersect(Target, Range("P:P")) Is Nothing Then
        Set fVal = Sheets("Sheet1").Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues)
        If Not fVal Is Nothing And Range("C" & fVal.Row) = "Task Summary" Then
        Target.Resize(1, 2).Copy Sheets("Sheet1").Range("Y" & fVal.Row)
    End If    
End Sub

 

[Raceman]

Ok thanks for the quick response, Your latest didn't work until I added another End If at the end, Does this make sense?

'This code provided by JLGWhiz automatically moves data from cells P and Q to Sheet 1 but only if Sh2 line says Task Summary
Dim fVal As Range
If Not Intersect(Target, Range("P:P")) Is Nothing Then
Set fVal = Sheets("MAD_CAT").Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues)
If Not fVal Is Nothing And Range("C" & fVal.Row) = "Task Summary" Then
Target.Resize(1, 2).Copy Sheets("MAD_CAT").Range("Y" & fVal.Row)
End If
End If
End Sub

 

[JLGWhiz]

Yep, don't know why I deleted that.
Regards, JLG

 

[Raceman]

Thanks much for your help, I really appreciate it!

 

[Raceman]

JLGWhiz:

I'm having major problems with this after I thought it was resolved. I didn't test it well enough I guess...my bad.

But I am not getting the desired result except for row 3 on the active sheet. An entry in column P, with "Task Summary" in C, produces a copy of P and Q to the MAD CAT sheet (Columns Y and Z) but only for the first row with data , which is row 3 on the active sheet.

'This will automatically provide dates where appropriate
Private Sub Worksheet_Change(ByVal Target As Range)
Set t = Target
Set dd = Range("$D$3:$D$5000")
Set ff = Range("$F$3:$F$5000")
Set hh = Range("$H$3:$H$5000")
Set jj = Range("$J$3:$J$5000")
Set ll = Range("$L$3:$L$5000")
Set nn = Range("$N$3:$N$5000")
Set pp = Range("$P$3:$P$5000")
If Target.Count > 1 Then Exit Sub
If (Intersect(t, dd) Is Nothing) And (Intersect(t, ff) Is Nothing) And (Intersect(t, dd) Is Nothing) And (Intersect(t, hh) Is Nothing) And (Intersect(t, jj) Is Nothing) And (Intersect(t, ll) Is Nothing) And (Intersect(t, nn) Is Nothing) And (Intersect(t, pp) Is Nothing) Then Exit Sub
Application.EnableEvents = False
t.Offset(0, 1).Value = Date
Application.EnableEvents = True

'This code automatically moves data from cells P and Q to Sheet 1 but only if Sh2 line says Task Summary
Dim fVal As Range
If Not Intersect(Target, Range("P3:P15")) Is Nothing Then
Set fVal = Sheets("MAD_CAT").Range("A:A").Find(Range("A" & Target.Row).Value, LookIn:=xlValues)
If Not fVal Is Nothing And Range("C" & fVal.Row) = "Task Summary" Then
Target.Resize(1, 2).Copy Sheets("MAD_CAT").Range("Y" & fVal.Row)
End If
End If
End Sub