How to insert (or create) new rows under every row that meets a certain condition?

[khjhzw]

Hello,

Thank you for reading my question. Could you please help me with this task?

I have to do a repetitive task with a quite a large excel worksheet (or table). I am wondering if there is way for me to do all this task at once or to save as much time as possible.

I want to insert (create/add) new rows under every row that meets a certain condition. To better understand what I am trying to do, please see the example below.

Suppose I have following worksheet

	A	B	C
1	chapter 1
2		length	15 pages
3		things to try	p10-11
4		things to try	p13
5	chapter 2
6		length	5 pages
7		things to try	p16
8	chapter 3
9		length	15 pages
10	chapter 4
11		length	20 pages
12		things to try	p43

I want to insert 2 new rows under every "chapter", that is under every row where there is an entry in column A. After that I want to add in each of the new rows a new entry, "word count" and "date started" respectively, in column B. The desired end result should look like the table below.

	A	B	C
1	chapter 1
		word count
		date started
2		length	15 pages
3		things to try	p10-11
4		things to try	p13
5	chapter 2
		word count
		date started
6		length	5 pages
7		things to try	p16
8	chapter 3
		word count
		date started
9		length	15 pages
10	chapter 4
		word count
		date started
11		length	20 pages
12		things to try	p43

Thank you so much for your help!

Regards,

Kang

[#2]

@khjhzw 

Run this macro:

Sub InsertRows()
    Dim rng As Range
    Dim r As Long
    Application.ScreenUpdating = False
    Set rng = Range("B:B").Find(What:="chapter*", LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False)
    If Not rng Is Nothing Then
        Do
            r = rng.Row
            rng.Offset(1).Resize(2).EntireRow.Insert
            rng.Offset(1, 1).Value = "word count"
            rng.Offset(2, 1).Value = "date started"
            Set rng = Range("B:B").Find(What:="chapter*", After:=rng, LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False)
            If rng Is Nothing Then Exit Do
        Loop Until rng.Row > r
    End If
    Application.ScreenUpdating = True
End Sub

[#3 · Accepted solution]

@khjhzw 

Sub insertrow()

Dim i As Integer
Dim j As Integer

For i = 1 To 1000

j = InStr(1, Cells(i, 1), "chapter", vbTextCompare)

If j = 1 Then
Cells(i + 1, 1).EntireRow.Insert
Cells(i + 2, 1).EntireRow.Insert

Cells(i + 1, 2).Value = "word count"
Cells(i + 2, 2).Value = "date started"

i = i + 2

Else
End If

Next i

End Sub

Maybe with these lines of code. Click the button in cell E1 in the attached file to start the macro.

[#4]

Thank you so much for your help. It works! Fabulous. Wonderful!

Regards,
Kang

[#5]

Dear Hans Vogelaar,

Thank you so much for your timely reply and helping me out for the second time. I really appreciate your help.

Regretfully, your macro didn't work. However, macro suggested by another person, "Quadruple_Pawn", did the job. I wish I could tell you why your macro didn't work, but I know nothing about excel macro. Please pardon me. Thank you anyway for your input!

Regards,
Kang