Replacing 1 row of data with several rows of data

[pford]

I am trying to replace a single row of data with several rows of data from another worksheet and have it repeat this process until there are no more occurrances.

Worksheet#1 has a list of parts and subassemblies. I want to break the subassemblies down into individual parts.

Worksheet#2 has a list of all subassemblies with all of the parts.

Worksheet#1
QTY PART#
1.00 23155-02
0.08 89982
0.08 89996
1.00 T102C-1B
1.00 T102C-1B/M
0.08 89987
0.08 89989

Worksheet#2
SUB-ASSY PART# QTY
T101C-1B 22660 2
T101C-1B 31887-02-AAAAA 1
T101C-1B 10989-01 1
T101C-1B 22147-01-AG 1
T101C-1B 22930-01-AAY 1
T101C-1B 22930-02-AAY 1
T101C-1B/M 22660 2
T101C-1B/M 40378-25-AG 1
T101C-1B/M 83994 13.5
T101C-1B/M 10989-01 1
T101C-1B/M 22147-01-AG 1
T101C-1B/M 22930-01-AAY 1
T101C-1B/M 22930-02-AAY 1

I need Worksheet#1 to look like this.
QTY PART#
1.00 23155-02
0.08 89982
0.08 89996
2.00 22660
1.00 31887-02-AAAAA
1.00 10989-01
1.00 22147-01-AG
1.00 22930-01-AAY
1.00 22930-02-AAY
2.00 22660
1.00 40378-25-AG
13.5 83994
1.00 10989-01
1.00 22147-01-AG
1.00 22930-01-AAY
1.00 22930-02-AAY
0.08 89987
0.08 89989

Thanks,
pford

 

[Jim North]

This should do it. It expects three worksheets:

MAIN - your current parts list
Subassemblies - details the parts
Explosion - end product of macro

<pre>

Sub BOM_Exploder()

Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim wks3 As Worksheet
Dim Sell As Range
Dim SubAssy As Range
Dim wks1CurrRow As Long
Dim wks3CurrRow As Long
Dim wks1LastRow As Long
Dim wks2LastRow As Long
Dim NextRow As Long
Dim Rng As Range
Dim c As Range
Dim FoundIt As Boolean

' turn off screen updating
Application.ScreenUpdating = False

' point to the worksheets
Set wks1 = Worksheets("Main")
Set wks2 = Worksheets("Subassemblies")
Set wks3 = Worksheets("Explosion")

' clear Explosion sheet
wks3.Columns("A:IV").Clear

' copy the headings from Main to Explosion
wks1.Rows("1:1").Copy
wks3.Rows("1:1").PasteSpecial Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

' point to Sheet1
wks1.Activate

' get the last of row on Main sheet
wks1LastRow = wks1.Range("B65536").End(xlUp).Row

' get the last row on Subassemblies sheet
wks2LastRow = wks2.Range("A65536").End(xlUp).Row

wks3CurrRow = 2
Set SubAssy = wks2.Range("A1:A" & wks2LastRow)
'
Set Rng = wks1.Range("B2:B" & wks1LastRow)
For Each Sell In Rng

With SubAssy
FoundIt = False
Set c = .Find(Sell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then ' at least one match is found
firstAddress = c.Address
Do
wks3.Cells(wks3CurrRow, 1).Value = c.Cells(1, 3).Value ' quantity
wks3.Cells(wks3CurrRow, 2).Value = c.Cells(1, 2).Value ' part number
wks3CurrRow = wks3CurrRow + 1
FoundIt = True
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
If FoundIt = False Then
wks3.Cells(wks3CurrRow, 1).Value = Sell.Offset(0, -1).Value ' quantity
wks3.Cells(wks3CurrRow, 2).Value = Sell.Value ' part number
wks3CurrRow = wks3CurrRow + 1
End If
End With

Next Sell

'point to cell A1 on Sheet2
wks3.Activate
Range("A1").Select
Application.ScreenUpdating = True

End Sub

</pre>