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]

Ideally the results would be the H21:K28 sequence.

OK, try this.
Assumption is that there is nothing in the original sheet to the right of column D, or at least nothing in columns E:G. If there is, post details of what else is on the sheet.

Original data

Excel Workbook
	A	B	C	D	E
1	ID	System Name	Name	Predecessors
2	1	Sys1	Task1	0
3	2	Sys2	Task2	1;29
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
14	29	Sys13	Task13	0
15
Data

Code (amend sheet name if required)

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

Result:

Excel Workbook
	A	B	C	D	E
1	ID	System Name	Name	Predecessors
2	2	Sys2	Task2	1;29
3	1	Sys1	Task1	0
4	29	Sys13	Task13	0
5	28	Sys9	Task9	23;27;8
6	8	Sys8	Task8	6
7	23	Sys11	Task11	0
8	27	Sys12	Task12	0
9
Sheet1

 

[Nick30075]

Many Thanks Peter, you have nailed it!
Thanks so much for your support!

 

[Peter_SSs]

Many Thanks Peter, you have nailed it!
Thanks so much for your support!

Cheers, glad to help. Thanks for letting us know.

 

[WarPigl3t]

Nick. I got your message. It is possible that the 23 is a string in the first variable and an integer in the second variable as you suggested. Just convert both variables to string and see if that fixes the problem. If it doesn't, I don't know. use the function CStr(variable)

eg. myValue = CStr(myValue)

 

[Nick30075]

Hi Peter,
Sorry to bother you again, but there are additional rows populated to the right of column D.
I tried to retrofit myself but have been unsuccessful.
Column P is the last column used.

Thanks!

Here is the final layout:

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	ID	WBS	UniqueID	System Name	Name	Start Date	Finish Date	Predecessor	Resource	Pred Sys Name	Pred Name	Pred Start	Pred Finish	% Complete	Diff	OriginalPred
subset (2)

 

[Peter_SSs]

1. Both the original data and the final results to have these 16 columns?

2. Column H is now the one with the semicolons?

3. Column A still the column that the semicolon list refers to? Or is it column C being "UniqueID".
If it is still column A, can you confirm that the IDs in that column are in fact unique?

 

[Nick30075]

Hi Peter,
This project had been pushed back but is now back on.
Answers to your questions:
1. Both the original data and the final results to have these 16 columns? correct
2. Column H is now the one with the semicolons? correct

3. Column A still the column that the semicolon list refers to? Or is it column C being "UniqueID". Col A
If it is still column A, can you confirm that the IDs in that column are in fact unique? Are Unique

Thanks!

 

[Peter_SSs]

Try

Sub Predecessors_v2()
  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("P" & wsOld.Rows.Count).End(xlUp))
    .AutoFilter Field:=8, Criteria1:="*;*"
    On Error Resume Next
    Set scRng = .Columns(8).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
    On Error GoTo 0
    .AutoFilter
    If Not scRng Is Nothing Then
      wsOld.Range("Z1").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(, 16).Copy Destination:=wsNew.Cells(nr, 1)
        wsOld.Range("Z2").Resize(UBound(Split(c.Value, ";")) + 1).Value = Application.Transpose(Split(c.Value, ";"))
        .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsOld.Range("Z1").CurrentRegion, CopyToRange:=wsNew.Cells(nr + 1, 1), Unique:=False
        wsNew.Rows(nr + 1).Delete
        wsOld.Range("Z1").CurrentRegion.Offset(1).ClearContents
      Next c
      wsOld.Range("Z1").ClearContents
      wsNew.UsedRange.EntireColumn.AutoFit
    End If
  End With
  Application.ScreenUpdating = True
End Sub

 

[Nick30075]

Hi Peter,
Thanks for the expanded column model post above in #28, you rock!

One final twist to try and apply to original 4 column post #21: After or during the code execution, can we remove a row if the System Name Value is the same as the System Name value of the first row in the range?

Many thanks!

 

[Nick30075]

Excel 2012
	A	B	C	D
1	Code produces this now:
2	Id	System Name	Name	Predecessors
3	28	Sys9	Task9	8;23;27
4	8	Sys8	Task8
5	23	Sys9	Task11	0
6	27	Sys12	Task12	0
7
8
9	Can we remove the duplicate system name from the result?
10	Id	System Name	Name	Predecessors
11	28	Sys9	Task9	8;23;27
12	8	Sys8	Task8
13	27	Sys12	Task12	0
result