asked on

Excel 2013 Macro to copy rows based on a criteria

Hi
I was just reading a solution explained by our member Saqib Husain, Syed in the thread https://www.experts-exchange.com/questions/28654243/Copy-data-from-Main-Sheet-to-multiple-sheets-based-on-a-criteria.html
I have a similar situation with excel 2013. I already sent a message to Syed with my request but not sure whether Syed is still active in this forum. Would anyone be able to help?

I would like to have a Macro in the ‘Task Allocation’ sheet to copy the rows from Column B to Column G and paste it to the individual ‘Team WiP’ sheet as per selection from the drop down list from column A in Sheet-‘Task Allocation’.

The selection of rows starts from row 6 only as row # 5 is the header

The entries in the ‘Task Allocation’ sheet need to be cut and copied across to the relevant sheets as per selection from column A.

As an example, if I select ‘Team 1’ from the dropdown list, the entire data on that row from column B to G need to be copied in to ‘Team1 WiP’ sheet. If there are more allocation to Team 1 from the Task allocation sheet, it would be copied to the next available row in the individual team sheet. Similarly, If I select Team 2, then the data will be copied to ‘Team2 WiP’ sheet. I have 6 teams to select from.

I have attached my sample file and the code I have which is not working is pasted below

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A6:A" & Range("B" & Rows.Count).End(xlUp).Row)) Is Nothing Then Exit Sub
    Range("B" & Target.Row & ":G" & Target.Row).Copy Sheets(Target.Value).Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
    Range("A6").Select
End Sub

Open in new window

Thanks in advance

Regards

Mali
Office-Work-Tracker.xlsm

Subodh Tiwari (Neeraj)

Please try something like this...

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    Dim dws As Worksheet
    If Intersect(Target, Range("A6:A" & Range("B" & Rows.Count).End(xlUp).Row)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    On Error GoTo Skip
    Application.EnableEvents = False
    If Target <> "" Then
        Set dws = Sheets(Target.Value)
        If Not dws Is Nothing Then
            Range("B" & Target.Row & ":G" & Target.Row).Copy dws.Range("B" & Rows.Count).End(3)(2)
            Range("A" & Target.Row & ":H" & Target.Row).Delete shift:=xlUp
        End If
    End If
    Range("A6").Select
    Application.ScreenUpdating = True
Skip:
    Application.EnableEvents = True
End Sub

Open in new window

Office-Work-Tracker.xlsm

SOLUTION

Matt Mali

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

ASKER CERTIFIED SOLUTION

Subodh Tiwari (Neeraj)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Matt Mali

ASKER

thanks tons Neeraj

I will try this at my office tomorrow and will let you know

Matt Mali

ASKER

Thanks again Neeraj

I tried the macro within the home settings and its a 100%. In office, it may take few more days to complete the formalities in setting up new folders at the senior management level. I will let you know

Matt Mali

ASKER

Thanks Neeraj. I am still waiting to clear the security restrictions in my office settings. If I need assistance I will open a new link

Subodh Tiwari (Neeraj)

You're welcome Matt!