# Replacing 1 row of data with several rows of data

#### pford

##### New Member
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

### Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
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
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)
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>

Replies
14
Views
7K

1,220,965
Messages
6,157,123
Members
451,399
Latest member
alchavar

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back