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

 

[WarPigl3t]

Sub myParentMacro()
     dataSheet = "Sheet1"
     outputSheet = createNewSheet
     columnSearch = "D"
     dataFirstRow = 2
     dataLastRow = Sheets(dataSheet).Range(columnSearch & Rows.Count).End(xlUp).Row
     dataHeaders = 1
     outputHeaders = 2
     outputNextRow = 3
     Call insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     Call checkEveryRow(dataSheet, outputSheet, columnSearch, dataFirstRow, dataLastRow)
End Sub

Function createNewSheet()
     Set WS = Sheets.Add
     createNewSheet = WS.Name
End Function

Sub insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     Sheets(outputSheet).Range("A1").Value = "New Sheet Results"
     Sheets(dataSheet).Rows(dataHeaders).Copy
     ActiveSheet.Paste Destination:= Sheets(outputSheet).Rows(outputHeaders)
End Sub

Sub checkEveryRow(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow)
     r = firstRow
     Do Until r > lastRow
          myValue = Sheets(dataSheet).Range(columnSearch & r).Value
          TrueOrFalse = doesValueHaveSemicolon(myValue)
          If TrueOrFalse = True Then
               Call CopyPaste(dataSheet, outputSheet, r, pasteRow)
               pasteRow = pasteRow + 1
          End If
          r = r + 1
     Loop
End Sub

Function doesValueHaveSemicolon(myValue)
     test = InStr(1, myValue, ";")
     If test = 0 Then
          doesValueHaveSemicolon = False
     Else
          doesValueHaveSemicolon = True
     End If
End Function

Sub CopyPaste(dataSheet, outputSheet, copyRow, pasteRow)
     Sheets(dataSheet).Rows(copyRow).Copy
     ActiveSheet.Paste Destination:= Sheets(outputSheet).Rows(pasteRow)
End Sub

 

[Nick30075]

Hi WarPigl3t,
the checkEveryRow call is generating a compile error.
The fix is to make the arguments = to the arguments under checkEveryRow sub correct?

Sub myParentMacro()
     dataSheet = "Sheet1"
     outputSheet = createNewSheet
     columnSearch = "D"
     dataFirstRow = 2
     dataLastRow = Sheets(dataSheet).Range(columnSearch & Rows.Count).End(xlUp).Row
     dataHeaders = 1
     outputHeaders = 2
     outputNextRow = 3
     Call insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     [B]Call checkEveryRow(dataSheet, outputSheet, columnSearch, dataFirstRow, dataLastRow[/B])
End Sub

Function createNewSheet()
     Set WS = Sheets.Add
     createNewSheet = WS.Name
End Function

Sub insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)     
Sheets(outputSheet).Range("A1").Value = "New Sheet Results"
     Sheets(dataSheet).Rows(dataHeaders).Copy
     ActiveSheet.Paste Destination:=Sheets(outputSheet).Rows(outputHeaders)
End Sub

[B]Sub checkEveryRow(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow)[/B]

Thanks!

 

[Nick30075]

Made the change noted above and then run into:
Run-time error '1004' Application-defined or object-defined error via the my value assignment bolded below:

Sub checkEveryRow(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow)
     r = firstRow
     Do Until r > lastRow
          [B]myValue = Sheets(dataSheet).Range(columnSearch & r).Value[/B]

 

[WarPigl3t]

Sub myParentMacro()
     dataSheet = "Sheet1"
     outputSheet = createNewSheet
     columnSearch = "D"
     dataFirstRow = 2
     dataLastRow = Sheets(dataSheet).Range(columnSearch & Rows.Count).End(xlUp).Row
     dataHeaders = 1
     outputHeaders = 2
     outputNextRow = 3
     Call insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     Call checkEveryRow(dataSheet, outputSheet, columnSearch, dataFirstRow, dataLastRow, outputNextRow)
End Sub

Function createNewSheet()
     Set WS = Sheets.Add
     createNewSheet = WS.Name
End Function

Sub insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     Sheets(outputSheet).Range("A1").Value = "New Sheet Results"
     Sheets(dataSheet).Rows(dataHeaders).Copy
     ActiveSheet.Paste Destination:= Sheets(outputSheet).Rows(outputHeaders)
End Sub

Sub checkEveryRow(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow)
     r = firstRow
     Do Until r > lastRow
          myValue = Sheets(dataSheet).Range(columnSearch & r).Value
          TrueOrFalse = doesValueHaveSemicolon(myValue)
          If TrueOrFalse = True Then
               Call CopyPaste(dataSheet, outputSheet, r, pasteRow)
               pasteRow = pasteRow + 1
          End If
          r = r + 1
     Loop
End Sub

Function doesValueHaveSemicolon(myValue)
     test = InStr(1, myValue, ";")
     If test = 0 Then
          doesValueHaveSemicolon = False
     Else
          doesValueHaveSemicolon = True
     End If
End Function

Sub CopyPaste(dataSheet, outputSheet, copyRow, pasteRow)
     Sheets(dataSheet).Rows(copyRow).Copy
     ActiveSheet.Paste Destination:= Sheets(outputSheet).Rows(pasteRow)
End Sub

 

[WarPigl3t]

The problem was in line number 11. I forgot to add outputNextRow to the parameter

 

[Nick30075]

Awesome!
That got us the first row written to a new sheet!
Now we need the other values in the semi colon delimited field rows to be copied into the new sheet so it'll look like this:
Almost there!

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

 

[WarPigl3t]

From what I can tell, the code does what it is suppose to. Your sheet example of what the new sheet should look like after the macro is not correct. Take row 3 for example. The ID number is 23, System Name is Sys11, Name is Task11, and Predecessors is 0. Let me repeat, Predecessors is 0. It does not contain a semicolon and therefore will not output to the new sheet as were your specifications. Did I misunderstand the requirements?

 

[WarPigl3t]

Oh I get what you're doing now. Predecessors are the ID of the other rows you want copied to the new sheet. This changes everything. Trash the macro I gave you. We need to start from scratch. Will get back with you. Its still an easy macro to build.

 

[WarPigl3t]

Sub myParentMacro()
     dataSheet = "Sheet1"
     outputSheet = createNewSheet
     columnSearch = "D"
     columnID = "A"
     dataFirstRow = 2
     dataLastRow = Sheets(dataSheet).Range(columnSearch & Rows.Count).End(xlUp).Row
     dataHeaders = 1
     outputHeaders = 2
     outputNextRow = 3
     Call insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     Call checkEveryRow(dataSheet, outputSheet, columnSearch, dataFirstRow, dataLastRow, outputNextRow, columnID)
End Sub

Function createNewSheet()
     Set WS = Sheets.Add
     createNewSheet = WS.Name
End Function

Sub insertHeaders(dataSheet, outputSheet, dataHeaders, outputHeaders)
     Sheets(outputSheet).Range("A1").Value = "New Sheet Results"
     Sheets(dataSheet).Rows(dataHeaders).Copy
     ActiveSheet.Paste Destination:= Sheets(outputSheet).Rows(outputHeaders)
End Sub

Sub checkEveryRow(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow, columnID)
     r = firstRow
     Do Until r > lastRow
          myValue = Sheets(dataSheet).Range(columnSearch & r).Value
          TrueOrFalse = doesValueHaveSemicolon(myValue)
          If TrueOrFalse = True Then
               Call CopyPaste(dataSheet, outputSheet, r, pasteRow)
               pasteRow = pasteRow + 1
               Call pastePredecessorRows(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow, myValue, columnID)
               pasteRow = Sheets(outputSheet).Range(columnSearch & Rows.Count).End(xlUp).Row + 1
          End If
          r = r + 1
     Loop
End Sub

Function doesValueHaveSemicolon(myValue)
     test = InStr(1, myValue, ";")
     If test = 0 Then
          doesValueHaveSemicolon = False
     Else
          doesValueHaveSemicolon = True
     End If
End Function

Sub CopyPaste(dataSheet, outputSheet, copyRow, pasteRow)
     Sheets(dataSheet).Rows(copyRow).Copy
     ActiveSheet.Paste Destination:= Sheets(outputSheet).Rows(pasteRow)
     Application.CutCopyMode = False
End Sub

Sub pastePredecessorRows(dataSheet, outputSheet, columnSearch, firstRow, lastRow, pasteRow, myValue, columnID)
     mySplit = Split(myValue, ";")
     For Each element in mySplit
          r = firstRow
          myValue = Sheets(dataSheet).Range(columnID & r).Value
          Do Until r > lastRow Or element = myValue
               r = r + 1
               myValue = Sheets(dataSheet).Range(columnID & r).Value
          Loop
          If element = myValue Then
               CopyPaste(dataSheet, outputSheet, r, pasteRow)
               pasteRow = pasteRow + 1
          End If
     Next element
End Sub