Insert rows and copied cells from another sheet under cells based on value

CourtJester

New Member
Joined
Feb 4, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
I've been driving myself crazy trying to figure this out.
Can someone please help?

The following is a generic list imported from an AutoCAD file and the WB-# stand for bundles represented in the second sheet:

Image 2-4-21 at 12.40 PM.jpg
Image 2-4-21 at 12.41 PM.jpg


The imported list will change based on the project but, the wire bundles stay the same.
I'm trying to insert the cells on the second sheet into the first, in place of the "WB-#"s to create a complete list.

For example:
Image 2-4-21 at 1.15 PM.jpg

I got as far as inserting new rows under the wire bundles but, can't figure out how to copy the info in.
Total noob here so don't judge me too harshly. I'm sure there's a simpler way to insert everything.

VBA Code:
Sub InsertWireBundleRows()

    Dim Col As Variant
    Dim BlankRows As Long
    Dim LastRow As Long
    Dim R As Long
    Dim StartRow As Long

        Col = "C"
        StartRow = 1
        BlankRows = 1

            LastRow = Cells(Rows.Count, Col).End(xlUp).Row

            Application.ScreenUpdating = False

            With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "WB-1" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-2" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-3" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-4" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-5" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-6F" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-7F" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-8F" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
ElseIf .Cells(R, Col) = "WB-TP" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True

End Sub
 

Attachments

  • Image 2-4-21 at 12.58 PM.jpg
    Image 2-4-21 at 12.58 PM.jpg
    19.7 KB · Views: 2

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,827
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Welcome to MrExcel Message Board.
If your first sheet is Sheet1 & Second sheet is Sheet2 . Try this:
VBA Code:
Sub InsertWBs()
Dim i As Long, Lr1 As Long, j As Long, A As Long, Lr2 As Long, Sh1 As Worksheet, Sh2 As Worksheet
Dim N As String, P As String, T As Long
Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")
Lr1 = Sh1.Range("A" & Rows.Count).End(xlUp).Row
Lr2 = Sh2.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To Lr2
If Sh2.Range("A" & i).Value <> "" Then
A = Sh2.Range("B" & i).End(xlDown).Row
For j = 2 To Lr1
If Sh1.Range("C" & j).Value = Sh2.Range("A" & i).Value Then
Sh1.Range("C" & j + 1).Resize(A - i).EntireRow.Insert
Sh1.Range("C" & j & ":C" & j + A - i).Value = Sh2.Range("B" & i & ":B" & A).Value
Lr1 = Sh1.Range("A" & Rows.Count).End(xlUp).Row
End If
Next j
End If
Next i

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,129,981
Messages
5,639,368
Members
417,083
Latest member
vijaykrrao

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
Top