Macro for Copying One Cell to another on Selection of Picklist

[Niv_Shah]

Hi Guys,
I have shared the link for my Workbook"Sample_NS", please see the below link.
https://drive.google.com/file/d/0BwN-9A9jHDNcXzU4R0ZQVFZOVnM/view?usp=sharing

In the "Sample_NS" workbook there are two worksheets "Ashok" and "Shruti"
both Sheet contains Task Owner and Team Member where Owner and Team Member is the Picklist

Now what I want is, on the Selection of Team member I want to copy the task in Relevant team members sheet

For E.g. In Sheet "Ashok" lets say for Task "T1" we have selected owner as "Nirdesh" and Team Member as "Shruti" so the Task "T1" should be copied to the sheet "Shruti"

Please advise
Thanks
Nirav

 

[Niv_Shah]

Hi Guys,
I need a Macro to copy the Data based on the selection of Picklist value. I also need to insert a blank row before adding the copied data

Please help

Thanks
Nirav

 

[Fishboy]

Hi Guys,
I need a Macro to copy the Data based on the selection of Picklist value. I also need to insert a blank row before adding the copied data

Please help

Thanks
Nirav

Hi Nirav, welcome to the boards.

On the understanding that you actually have a sheet set up for each possible team member then the following Worksheet_Change macro will automatically copy the task across to the corresponding team member, from row 40 onwards, with a gap blank row between tasks. To test it out you will need to right-click on the tab name of the "main" sheet and select View Code. In the new window that opens copy / paste in the following:

Private Sub Worksheet_Change(ByVal Target As Range)Dim LastRow As Long, wsLastRow As Long
Dim ws As Worksheet
Dim TeamName As String


LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1


If Not Intersect(Target, Range("C2:C" & LastRow)) Is Nothing Then
    If Target.Value <> "" Then
        TeamName = Target.Value
        Set ws = Sheets(TeamName)
        If ws.Range("A40") = "" Then
            ws.Range("A40").Value = ActiveSheet.Range("A" & Target.Row).Value
        Else
            wsLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 2
            ws.Range("A" & wsLastRow).Value = ActiveSheet.Range("A" & Target.Row).Value
    End If
End If


End Sub

Note that if you select a team member and there is no sheet already in place for that person then the macro will error.

 

[Niv_Shah]

Hi Nirav, welcome to the boards.

On the understanding that you actually have a sheet set up for each possible team member then the following Worksheet_Change macro will automatically copy the task across to the corresponding team member, from row 40 onwards, with a gap blank row between tasks. To test it out you will need to right-click on the tab name of the "main" sheet and select View Code. In the new window that opens copy / paste in the following:

Private Sub Worksheet_Change(ByVal Target As Range)Dim LastRow As Long, wsLastRow As Long
Dim ws As Worksheet
Dim TeamName As String


LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1


If Not Intersect(Target, Range("C2:C" & LastRow)) Is Nothing Then
    If Target.Value <> "" Then
        TeamName = Target.Value
        Set ws = Sheets(TeamName)
        If ws.Range("A40") = "" Then
            ws.Range("A40").Value = ActiveSheet.Range("A" & Target.Row).Value
        Else
            wsLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 2
            ws.Range("A" & wsLastRow).Value = ActiveSheet.Range("A" & Target.Row).Value
    End If
End If


End Sub

Note that if you select a team member and there is no sheet already in place for that person then the macro will error.

Hi,
Thanks for your reply and help.
I have tried with the above code but it didn't work for me.
It neither gives any error nor performing any actions

Please Help

Thanks
Nirav

 

[Fishboy]

Hi,
Thanks for your reply and help.
I have tried with the above code but it didn't work for me.
It neither gives any error nor performing any actions

Please Help

Thanks
Nirav

Hmm, you can download my updated copy of your own sample workbook HERE and see that is should be doing what you describe. As I mentioned before you do not have a corresponding sheet for all possible values yet, so only Ashtok and Shruti will currently work, however if you replicate the sheets for each possible team member then the code should already be capable of handling that.

 

[Niv_Shah]

Hmm, you can download my updated copy of your own sample workbook HERE and see that is should be doing what you describe. As I mentioned before you do not have a corresponding sheet for all possible values yet, so only Ashtok and Shruti will currently work, however if you replicate the sheets for each possible team member then the code should already be capable of handling that.

Hi,
Thank you very much for your efforts and help.
This is exactly as I want, now in the macro can we add a new row below A:40 if Range(A:40) is not empty?
and paste the task in the newly created row

Thanks
Nirav

 

[Fishboy]

Hi,
Thank you very much for your efforts and help.
This is exactly as I want, now in the macro can we add a new row below A:40 if Range(A:40) is not empty?
and paste the task in the newly created row

Thanks
Nirav

You said you wanted a blank row in between each value right?

I also need to insert a blank row before adding the copied data

It should already be doing that, as per your original request. If A40 is empty, it puts the value in there. If A40 is not empty then it works out the last row, then moves 2 rows down and puts the copied values there.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, wsLastRow As Long
Dim ws As Worksheet
Dim TeamName As String


LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1


If Not Intersect(Target, Range("C2:C" & LastRow)) Is Nothing Then
    If Target.Value <> "" Then
        TeamName = Target.Value
        Set ws = Sheets(TeamName)
        If ws.Range("A40") = "" Then
            ws.Range("A40").Value = ActiveSheet.Range("A" & Target.Row).Value
        Else
            wsLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 2
            ws.Range("A" & wsLastRow).Value = ActiveSheet.Range("A" & Target.Row).Value
        End If
    End If
End If


End Sub

 

[Niv_Shah]

You said you wanted a blank row in between each value right?



It should already be doing that, as per your original request. If A40 is empty, it puts the value in there. If A40 is not empty then it works out the last row, then moves 2 rows down and puts the copied values there.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, wsLastRow As Long
Dim ws As Worksheet
Dim TeamName As String


LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1


If Not Intersect(Target, Range("C2:C" & LastRow)) Is Nothing Then
    If Target.Value <> "" Then
        TeamName = Target.Value
        Set ws = Sheets(TeamName)
        If ws.Range("A40") = "" Then
            ws.Range("A40").Value = ActiveSheet.Range("A" & Target.Row).Value
        Else
            wsLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 2
            ws.Range("A" & wsLastRow).Value = ActiveSheet.Range("A" & Target.Row).Value
        End If
    End If
End If


End Sub

Yes currently it is entering in the blank row but if I have record in A:45 than I need to enter one row and add data in that

 

[Niv_Shah]

and one more thing, how can copy the entire row?

Thanks

 

[Fishboy]

Yes currently it is entering in the blank row but if I have record in A:45 than I need to enter one row and add data in that

Again, it should already be doing that. If there is a record in A45 with no data below it then A45 is the last row. Therefore the macro should add the data to A47. I don't understand how it is not already doing what you describe...

and one more thing, how can copy the entire row?

Thanks

These changes should copy the entire row rather than just the value in column A:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, wsLastRow As Long
Dim ws As Worksheet
Dim TeamName As String


LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row + 1


If Not Intersect(Target, Range("C2:C" & LastRow)) Is Nothing Then
    If Target.Value <> "" Then
        TeamName = Target.Value
        Set ws = Sheets(TeamName)
        If ws.Range("A40") = "" Then
            ActiveSheet.Range("A" & Target.Row).EntireRow.Copy ws.Range("A40").EntireRow
        Else
            wsLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 2
            ActiveSheet.Range("A" & Target.Row).EntireRow.Copy ws.Range("A" & wsLastRow).EntireRow
        End If
    End If
End If


End Sub