Replacing 1 row of data with several rows of data

pford

New Member
Joined
Sep 3, 2002
Messages
2
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 fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
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>
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,150
Members
448,552
Latest member
WORKINGWITHNOLEADER

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top