Copy Parent and Child rows based on Parent and Child state value

B0l0ts

New Member
Joined
Jan 30, 2020
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hello Everyone. I have been trying to find a solution on my vba issue for a number of days now. I tried searching in the forum but could not get it to work for my purpose. I am very much a newbie with VBA and the code I have been trying to put together is just so messed up now. Any help from anyone is very much appreciated.

Problem:
I have a worksheet with around 800 rows. The rows are basically an extract of PBIs and Tasks from TFS and they are already grouped together by Parent and it's corresponding child tasks. What I want to get from these records is to extract all of the Parent (PBI) row that is not = "Done" where ALL of its corresponding Child tasks are already set to "Done".

The Parent and Child records are identified as "P" and "C" respectively under the Level column. And all of the Child rows are numbered in sequence within each group.

Below is a snapshot of what my data looks like and what I am expecting as an output.

Apologies for the trouble and thanks in advance!
 

Attachments

  • Snapshot.png
    Snapshot.png
    44.6 KB · Views: 139

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Assuming your first header (ID) is in cell A1, there are no blank rows in your data, and no formula cells in your data, this will place your Result starting in cell I1. Caution, if you have data in cols I:O, it may be overwritten. Try this on a copy of your sheet.
VBA Code:
Sub ParentAndChild()
Dim R As Range, V As Variant, i As Long, Ar As Range, Ct As Long, NxRw As Long
Set R = Range("A1").CurrentRegion
V = R.Value
On Error Resume Next
R.SpecialCells(xlCellTypeBlanks).Value = "temp"
On Error GoTo 0
Application.ScreenUpdating = False
For i = R.Rows.Count To 2 Step -1
    If R.Rows(i).Cells(1, 5).Value = "P" And R.Rows(i - 1).Cells(1, 5).Value = "C" Then
        R.Rows(i).Insert shift:=xlDown
    End If
Next i
Set R = R.Offset(1, 0).SpecialCells(xlCellTypeConstants)
For i = 1 To R.Areas.Count
    If R.Areas(i).Cells(1, 7).Value <> "Done" Then
        Ct = Ct + 1
        If Application.CountIf(R.Areas(i).Columns(7), "Done") = R.Areas(i).Rows.Count - 1 Then
            If Ct = 1 Then
                R.Areas(i).Copy Destination:=Cells(2, "I")
            Else
                NxRw = Cells(Rows.Count, "I").End(xlUp).Row + 1
                R.Areas(i).Copy Destination:=Cells(NxRw, "I")
            End If
        End If
    End If
Next i
With Range("I1:O1")
    .Value = Range("A1:G1").Value
    .EntireColumn.AutoFit
End With
R.ClearContents
Range("A1:G" & UBound(V, 1)).Value = V
Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,553
Messages
6,114,279
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top