split BOM by reference designators

[22strider]

Hello Friends

Could anyone please help figuring out macro (VBA routine) for the following?
The original spreadsheet has bill of materials (BOM) export with columns ParentItem, ChildItem, Qty and RefDesig. Following is the sample table:
ParentItem Child Item Qty RefDesig
P12345 C12345 2 R12,R23
P12345 C45678 3 C56,C45,C89
P12345 C6598 4

Entries under column RefDesig are separated by comma.
I need a macro that would read and count entries under RefDesig and enter rows one each for RefDesig and change qty from its original number to 1. And if there is no RefDesig the Qty will remain as is.
Following is the table showing expected output:
ParentItem Child Item Qty RefDesig
P12345 C12345 1 R12
P12345 C12345 1 R23
P12345 C45678 1 C56
P12345 C45678 1 C45
P12345 C45678 1 C89
P12345 C6598 4

You may notice that the row one (in the original table) has been split into two rows (because in original table it had 2 reference designators) and the row two has been split into three rows. And row three in the original table remains as is in the result table because there was no reference designator.
Thanks
Rajesh

 

[hiker95]

22strider,

Be right back.

 

[hiker95]

22strider,


Sample raw data:

Excel Workbook
	A	B	C	D
1	ParentItem	ChildItem	Qty	RefDesig
2	P12345	C12345	2	R12,R23
3	P12345	C45678	3	C56,C45,C89
4	P12345	C6598	4
5
6
7
8
Sheet1

After the macro:

Excel Workbook
	A	B	C	D
1	ParentItem	ChildItem	Qty	RefDesig
2	P12345	C12345	1	R12
3	P12345	C12345	1	R23
4	P12345	C45678	1	C56
5	P12345	C45678	1	C45
6	P12345	C45678	1	C89
7	P12345	C6598	4
8
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub SplitBOM()
' hiker95, 02/13/2012
' http://www.mrexcel.com/forum/showthread.php?t=613198
Dim r As Long, lr As Long, Sp, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = lr To 2 Step -1
  If Cells(r, 4) = "" Or InStr(Cells(r, 4), ",") = 0 Then
    'do nothing
  ElseIf InStr(Cells(r, 4), ",") > 0 Then
    Sp = Split(Trim(Cells(r, 4)), ",")
    Rows(r + 1).Resize(UBound(Sp)).Insert
    Cells(r, 1).Resize(UBound(Sp) + 1, 2).Value = Cells(r, 1).Resize(, 2).Value
    Cells(r, 3).Resize(UBound(Sp) + 1) = Cells(r, 3) / (UBound(Sp) + 1)
    Cells(r, 4).Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
  End If
Next r
Application.ScreenUpdating = True
End Sub

Then run the SplitBOM macro.

 

[22strider]

That is brilliant.

Thank you

 

[hiker95]

22strider,

Thanks for the feedback.

You are very welcome.

Come back anytime.

 

[22strider]

Hello Hiker95

Could you plesae help me understand following portion of your code:

Rows(r + 1).Resize(UBound(Sp)).Insert
Cells(r, 1).Resize(UBound(Sp) + 1, 2).Value = Cells(r, 1).Resize(, 2).Value
Cells(r, 3).Resize(UBound(Sp) + 1) = Cells(r, 3) / (UBound(Sp) + 1)
Cells(r, 4).Resize(UBound(Sp) + 1) = Application.Transpose(Sp)

I am somewhat fimiliar with VBA but not able to understand this section.

Thanks again for your help
Rajesh

 

[Rick Rothstein]

Option Explicit
Sub SplitBOM()
' hiker95, 02/13/2012
' http://www.mrexcel.com/forum/showthread.php?t=613198
Dim r As Long, lr As Long, Sp, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = lr To 2 Step -1
  If Cells(r, 4) = "" Or InStr(Cells(r, 4), ",") = 0 Then
    'do nothing
  ElseIf InStr(Cells(r, 4), ",") > 0 Then
    Sp = Split(Trim(Cells(r, 4)), ",")
    Rows(r + 1).Resize(UBound(Sp)).Insert
    Cells(r, 1).Resize(UBound(Sp) + 1, 2).Value = Cells(r, 1).Resize(, 2).Value
    Cells(r, 3).Resize(UBound(Sp) + 1) = Cells(r, 3) / (UBound(Sp) + 1)
    Cells(r, 4).Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
  End If
Next r
Application.ScreenUpdating = True
End Sub

Just a quick note - you can simplify your code just a little bit by replacing the three lines of code I highlighted in red above with this single line of code...

[COLOR=black]If InStr(Cells(r, 4).Value, ",") Then[/COLOR]

The InStr function will not mind if the cell is value is empty or not, so there is no need to individually check for that situation.

 

[hiker95]

Rick Rothstein,

That is one for my archives.

Thank you.

 

[hiker95]

22strider,

Could you plesae help me understand following portion of your code:

I hope the following helps you to understand what the code is doing.

Option Explicit
Sub SplitBOM()
' hiker95, 02/13/2012
' http://www.mrexcel.com/forum/showthread.php?t=613198
Dim r As Long, lr As Long, Sp, n As Long
Application.ScreenUpdating = False

'find the last used cell in column 1 = "A"
lr = Cells(Rows.Count, 1).End(xlUp).Row

'loop thru column 4 = "D"
'  from the last row to row 2
For r = lr To 2 Step -1
  
  'if the cells in column 4 = "D" are blank
  '  or, the cell does not contain a "," character
  '  then do nothing
  If Cells(r, 4) = "" Or InStr(Cells(r, 4), ",") = 0 Then
    'do nothing
    
  'if the cell in column e = "D"
  '  contains the "," character, then the
  '  InStr will be greater than 0
  ElseIf InStr(Cells(r, 4), ",") > 0 Then
  
    'Sp is an array (Option Base 0)
    '  Split the cell in column 4 = "D" by the "," character
    Sp = Split(Trim(Cells(r, 4)), ",")
    
    'Insert a row(s) at the next row down from row r
    'If the UBound(SP) = 1
    '  then insert 1 row
    'If the UBond(SP) = 2
    '  then insert 2 rows, .....
    Rows(r + 1).Resize(UBound(Sp)).Insert
    
    'Fill columns A and B from row r to the number of rows inserted
    '  with the value in columns A and B in row r
    Cells(r, 1).Resize(UBound(Sp) + 1, 2).Value = Cells(r, 1).Resize(, 2).Value
    
    'Fill the cells in column 3 = "C"
    '  from row r to the number of rows inserted
    '  with the original value in Cells(r,3) divided by
    '  the number of rows inserted + 1
    Cells(r, 3).Resize(UBound(Sp) + 1) = Cells(r, 3) / (UBound(Sp) + 1)
    
    'Fill the cells in column 4 = "D"
    '  from row r to the number of rows inserted
    '  with the values from the Sp array
    Cells(r, 4).Resize(UBound(Sp) + 1) = Application.Transpose(Sp)
  End If
Next r
Application.ScreenUpdating = True
End Sub

 

[22strider]

thank you very much