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
Matt MaliAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
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
1
Matt MaliAuthor Commented:
Thanks Neeraj for taking the effort to help me.

It is working 100 % perfectly

Is there a way I can add a feature into this existing code so that the data copied is also pasted in to another sheet in a separate folder using a file path.

For example, when I choose 'Team1 WiP' from the Tasks allocation sheet, the row is cut and copied to the 'Team1 WiP' sheet within the same workbook and also into another workbook in another folder using the file path, "C:\Users\Secured Drive\Team1 WiP\Teamleader1.xlsm"
Similarly separate folders is created for the six teams as per below

"C:\Users\Secured Drive\Team2 WiP\Teamleader2.xlsm"
"C:\Users\Secured Drive\Team3 WiP\Teamleader3.xlsm"
"C:\Users\Secured Drive\Team4 WiP\Teamleader4.xlsm"
"C:\Users\Secured Drive\Team5 WiP\Teamleader5.xlsm"
"C:\Users\Secured Drive\Team6 WiP\Teamleader6.xlsm"

Many thanks once again

Regards

Mali
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
In that case you may try something like this...

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    Dim dws As Worksheet, dws2 As Worksheet
    Dim dwb2 As Workbook
    Dim dwbPath As String, Team As String, TeamNo As String
    
    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)
        Team = VBA.Trim(Left(Target.Value, InStr(Target.Value, " ") - 1))
        TeamNo = ExtractNumber(Target.Value)
        dwbPath = "C:\Users\Secured Drive\" & Team & " WiP\Teamleader" & TeamNo & ".xlsm"
        If Dir(dwbPath) <> "" Then
            Set dwb2 = Workbooks.Open(dwbPath, False)
        End If
        If Not dws Is Nothing Then
            Range("B" & Target.Row & ":G" & Target.Row).Copy dws.Range("B" & Rows.Count).End(3)(2)
            If Not dwb2 Is Nothing Then
                Set dws2 = dwb2.Sheets(1)
                Range("B" & Target.Row & ":G" & Target.Row).Copy
                dws2.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteAll
                dwb2.Close True
            End If
            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-v2.xlsm
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Matt MaliAuthor Commented:
thanks tons Neeraj

I will try this at my office tomorrow and will let you know
0
Matt MaliAuthor Commented:
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
0
Matt MaliAuthor Commented:
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
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Matt!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.