Code to add row and content

seeker123

Board Regular
Joined
Oct 8, 2011
Messages
84
Hi everyone
I have a large table that is something like this
Ducting
Ducting First floor
Painting
Painting First floor
Isolation
Isolation First floor

<tbody>
</tbody>
and so on
I want to add rows for six floors and have a table like below
Ducting
Ducting first floor
Ducting Second floor
Ducting Third floor
Ducting forth Floor
Ducting fifth floor
Ducting sixth floor
Painting
Painting first floor
painting second floor
painting third floor
Painting fourth floor
painting fifth floor
painting sixth floor

<tbody>
</tbody>
can you help me?
thanks in advance
 

Some videos you may like

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,575
Office Version
  1. 365
Platform
  1. Windows
Try this:

Code:
[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] A1084824A()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1084824-code-add-row-content.html[/COLOR][/I]
[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], j [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] va, vb, arr, s1, s2, x

Application.ScreenUpdating = [COLOR=Royalblue]False[/COLOR]
arr = Split([COLOR=brown]"Second Third Forth Fifth Sixth"[/COLOR])
va = Range([COLOR=brown]"A1"[/COLOR], Cells(Rows.count, [COLOR=brown]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))

[COLOR=Royalblue]ReDim[/COLOR] vb([COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR]) * [COLOR=crimson]5[/COLOR], [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=crimson]1[/COLOR])

[COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
    [COLOR=Royalblue]If[/COLOR] InStr([COLOR=crimson]1[/COLOR], va(i, [COLOR=crimson]1[/COLOR]), [COLOR=brown]"first floor"[/COLOR], [COLOR=crimson]1[/COLOR]) [COLOR=Royalblue]Then[/COLOR]
        s1 = Split(va(i, [COLOR=crimson]1[/COLOR]), [COLOR=brown]" "[/COLOR])([COLOR=crimson]0[/COLOR])
            s2 = Split(va(i, [COLOR=crimson]1[/COLOR]), [COLOR=brown]" "[/COLOR])([COLOR=crimson]2[/COLOR])
                j = j + [COLOR=crimson]1[/COLOR]
                    vb(j, [COLOR=crimson]1[/COLOR]) = va(i, [COLOR=crimson]1[/COLOR])
        [COLOR=Royalblue]For[/COLOR] [COLOR=Royalblue]Each[/COLOR] x [COLOR=Royalblue]In[/COLOR] arr
            j = j + [COLOR=crimson]1[/COLOR]
            vb(j, [COLOR=crimson]1[/COLOR]) = s1 & [COLOR=brown]" "[/COLOR] & x & [COLOR=brown]" "[/COLOR] & s2
        [COLOR=Royalblue]Next[/COLOR]
    [COLOR=Royalblue]Else[/COLOR]
        j = j + [COLOR=crimson]1[/COLOR]
        vb(j, [COLOR=crimson]1[/COLOR]) = va(i, [COLOR=crimson]1[/COLOR])
    [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
[COLOR=Royalblue]Next[/COLOR]

Range([COLOR=brown]"A1"[/COLOR]).Resize(j, [COLOR=crimson]1[/COLOR]) = vb
Application.ScreenUpdating = [COLOR=Royalblue]True[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,767
Office Version
  1. 365
Platform
  1. Windows
A different method to one used by @Akuini
- add an empty formatted row at bottom of data before you begin (Note ***)

To test
- double click on cell containing "Painting First floor" and row inserted containing "Painting Second floor"

Put this in SHEET module (right click sheet tab\ select view code \ paste into code window)
Code:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    Dim cel As Range, arr, a As Long
    arr = Split("First,Second,Third,Fourth,Fifth,Sixth,Seventh,Eighth,Ninth,Tenth", ",")
    Set cel = ActiveCell
    Rows(cel.Row + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    For a = 0 To UBound(arr)
        If InStr(1, cel, Trim(arr(a))) > 0 Then
            On Error Resume Next
            cel.Offset(1).Value = Replace(cel, arr(a), arr(a + 1))
            Exit For
        End If
    Next a
End Sub

Excel 2016 (Windows) 32 bit
A
B
C
1
Ducting
2
Ducting First floor
3
Painting
4
Painting First floor
5
Painting Second floor
6
Isolation
7
Isolation First floor
8
Isolation Second floor
9
Note **
add a blank row with borders at foot of table
Sheet: Sheet1
 

Watch MrExcel Video

Forum statistics

Threads
1,109,272
Messages
5,527,710
Members
409,784
Latest member
AdamPriest

This Week's Hot Topics

Top