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: 20

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,389
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,346
Messages
5,601,079
Members
414,426
Latest member
fraru

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
Top