Generate subset table from Master table

[Nick30075]

I have a table that looks like this:
Need Col D values that have ";" present to be parsed out to create and new worksheet with the results looking like the output below.

I've looked & tried but is beyond my level at this time. Any & all help is greatly appreciated!

Excel 2010
	A	B	C	D
1	ID	System Name	Name	Predecessors
2	1	Sys1	Task1	0
3	2	Sys2	Task2	1
4	3	Sys3	Task3	2
5	4	Sys4	Task4	5
6	5	Sys5	Task5	0
7	6	Sys6	Task6	0
8	7	Sys7	Task7	5
9	8	Sys8	Task8	6
10	28	Sys9	Task9	23;27;8
11	7	Sys10	Task10	27
12	23	Sys11	Task11	0
13	27	Sys12	Task12	0
Sheet4

Need output like this in a new worksheet:

Excel 2010
	A	B	C	D
1	New sheet results
2	ID	System Name	Name	Predecessors
3	28	Sys9	Task9	23;27;8
4	23	Sys11	Task11	0
5	27	Sys12	Task12	0
6	8	Sys8	Task8	6
Sheet1

 

[Peter_SSs]

I'm no longer sure about your columns.

Please confirm, for the original data sheet ..
- The extent of all columns used (previously was A:P)
- The Predecessors column (was H)
- The Id column (A)
- System Name column (B)

Is any repetition of the System name always a repeat of the value in the first row of the group like your sample above? That is, the row with the semicolons?

 

[Nick30075]

see answers below:

- The extent of all columns used = A:D
- The Predecessors column = D
- The Id column = A
- System Name column = B

Is any repetition of the System name always a repeat of the value in the first row of the group like your sample above? Correct
That is, the row with the semicolons? Correct

After or during the code execution, remove a row if the System Name Value is the same as the System Name value of the first row in the range?
If all System Names in the range are the same, delete the entire range

Thanks!

This is the original "4" column code from post 21 above:

Sub Predecessors()
  Dim scRng As Range, c As Range
  Dim nr As Long
  Dim wsOld As Worksheet, wsNew As Worksheet
  
  Set wsOld = Sheets("Data")  '<- Change to match your sheet name
  Application.ScreenUpdating = False
  With wsOld.Range("A1", wsOld.Range("D" & wsOld.Rows.Count).End(xlUp))
    .AutoFilter Field:=4, Criteria1:="*;*"
    On Error Resume Next
    Set scRng = .Columns(4).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
    On Error GoTo 0
    .AutoFilter
    If Not scRng Is Nothing Then
      wsOld.Range("F1").Value = wsOld.Range("A1").Value
      Set wsNew = Sheets.Add(After:=wsOld)
      .Rows(1).Copy Destination:=wsNew.Range("A1")
      For Each c In scRng
        nr = wsNew.Range("A" & wsNew.Rows.Count).End(xlUp).Row + 1
        c.EntireRow.Resize(, 4).Copy Destination:=wsNew.Cells(nr, 1)
        wsOld.Range("F2").Resize(UBound(Split(c.Value, ";")) + 1).Value = Application.Transpose(Split(c.Value, ";"))
        .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsOld.Range("F1").CurrentRegion, CopyToRange:=wsNew.Cells(nr + 1, 1), Unique:=False
        wsNew.Rows(nr + 1).Delete
        wsOld.Range("F1").CurrentRegion.Offset(1).ClearContents
      Next c
      wsOld.Range("F1").ClearContents
      wsNew.Columns("A:D").AutoFit
    End If
  End With
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

see answers below:

- The extent of all columns used = A:D
- The Predecessors column = D
- The Id column = A
- System Name column = B

Is any repetition of the System name always a repeat of the value in the first row of the group like your sample above? Correct
That is, the row with the semicolons? Correct

Try

Sub Predecessors_v3()
  Dim scRng As Range, c As Range
  Dim nr As Long
  Dim wsOld As Worksheet, wsNew As Worksheet
  
  Const f As String = "=AND(OR(A2={#}),B2<>""@"")"
  
  Set wsOld = Sheets("Data")  '<- Change to match your sheet name
  Application.ScreenUpdating = False
  With wsOld.Range("A1", wsOld.Range("D" & wsOld.Rows.Count).End(xlUp))
    .AutoFilter Field:=4, Criteria1:="*;*"
    On Error Resume Next
    Set scRng = .Columns(4).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
    On Error GoTo 0
    .AutoFilter
    If Not scRng Is Nothing Then
      Set wsNew = Sheets.Add(After:=wsOld)
      .Rows(1).Copy Destination:=wsNew.Range("A1")
      For Each c In scRng
        wsOld.Range("Z2").Formula = Replace(Replace(f, "#", Replace(c.Value, ";", ",")), "@", .Range("B" & c.Row).Value)
        nr = wsNew.Range("A" & wsNew.Rows.Count).End(xlUp).Row + 1
        c.EntireRow.Resize(, 4).Copy Destination:=wsNew.Cells(nr, 1)
        .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsOld.Range("Z1:Z2"), CopyToRange:=wsNew.Cells(nr + 1, 1), Unique:=False
        wsNew.Rows(nr + 1).Delete
      Next c
      wsOld.Range("Z2").ClearContents
      wsNew.UsedRange.EntireColumn.AutoFit
    End If
  End With
  Application.ScreenUpdating = True
End Sub

 

[Nick30075]

Hi Peter,
Works great, is it possible to remove the row with the semi colons also if all System Names in the range are the same? (delete the entire range)
In the example below, rows 2 thru 14 would be deleted.

Thanks!

Excel 2010
	A	B	C	D
1	ID	System Name	Name	Predecessors
2	27	150uS Water System	Execute FAT Protocol	23;24;25;26
3	37	150uS Water System	Execute SAT Protocol	33;34;35;36
4	47	150uS Water System	Execute (IOQ) Protocol	43;44;45;46
5	89	PURIFIED WATER	Execute FAT Protocol	85;88
6	99	PURIFIED WATER	Execute SAT Protocol	95;96;97;98
7	122	PURIFIED WATER	Review and release PQ1 test results	120;121
8	131	PURIFIED WATER	Review and release PQ1 test results	129;130
9	140	PURIFIED WATER	Review and release PQ1 test results	138;139
10	171	PURIFIED WATER - Loop 6 & 7	Review and release PQ1 test results	169;170
11	180	PURIFIED WATER - Loop 6 & 7	Review and release PQ2 test results	178;179
12	189	PURIFIED WATER - Loop 6 & 7	Review and release PQ3 test results	187;188
13	262	HOT PROCESS WATER	Execute FAT Protocol	258;259;260;261
14	272	HOT PROCESS WATER	Execute SAT Protocol	268;269;270;271
15	367	TANK FARM	Resolve Action Items	434;424
16	424	Solvent Supply System	Execute SAT Protocol
17	434	Solvent Supply System	Execute (IOQ) Protocol
18	368	TANK FARM	Close CR	438;428
19	428	Solvent Supply System	Route SAT Protocol for post-execution approval	427
20	438	Solvent Supply System	Route (IOQ) Protocol for post-execution approval	437
Sheet7

 

[Peter_SSs]

Does adding this blue line of code where indicated achieve what you want?

  wsNew.Rows(nr + 1).Delete
  If wsNew.Range("A" & wsNew.Rows.Count).End(xlUp).Row = nr Then wsNew.Rows(nr).Delete
Next c

 

[Nick30075]

It certainly does!
Thanks for all your help, is very much appreciated!

 

[Peter_SSs]

You are welcome.