Insert X number of rows based on variable text string search and input text

[dubmartian]

I would like to edit this script to add text to inserted rows.
Every insert row will be 2 and I would like to add text to the two cells.

example:

apple
pear
bananna
(scripts inserts 2 rows after every occasion of bananna)
inserted row 1 ( text string included = "help")
inserted row 2 (text string included = "me")
peach
strawberry

end example

Can this be done?

The code Im using ->

Option Explicit


Sub Insert_Rows()

Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long
Dim strTxt As String

Application.ScreenUpdating = False

lastrow = Cells(Rows.Count, "C").End(xlUp).Row

lRows = Application.InputBox("How many rows do you want to insert?", Type:=1)

If lRows < 1 Then
MsgBox " You must enter a number greater than zero"
Exit Sub
End If

strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.")

If Len(strTxt) < 1 Then
MsgBox "You must enter a text string consisting of at least one character"
Exit Sub
End If

With ActiveSheet

lngCount = Application.WorksheetFunction.CountIf(.Range("C1:C" & lastrow), strTxt)

If lngCount < 1 Then
MsgBox "The text string you entered is not listed - cancelling", vbExclamation
Exit Sub
End If

On Error Resume Next

For i = lastrow To 1 Step -1
If .Cells(i, 3).Value = strTxt Then
.Range("C" & i + 1 & ":C" & i + lRows).Insert shift:=xlDown
End If
Next i

End With

Application.ScreenUpdating = True


End Sub

 

[Fluff]

Do you just want to insert new cells into col C or add entire rows?

 

[dubmartian]

Do you just want to insert new cells into col C or add entire rows?

In the script provided I am shifting down in col C I would like to shift the entire row but only adds the text into the new rows specifically for col C

 

[Fluff]

In that case try this

Sub Insert_Rows()

Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long
Dim strTxt As String

Application.ScreenUpdating = False

lastrow = Cells(Rows.Count, "C").End(xlUp).Row


strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.")

If Len(strTxt) < 1 Then
MsgBox "You must enter a text string consisting of at least one character"
Exit Sub
End If

With ActiveSheet

lngCount = Application.WorksheetFunction.CountIf(.Range("C1:C" & lastrow), strTxt)

If lngCount < 1 Then
MsgBox "The text string you entered is not listed - cancelling", vbExclamation
Exit Sub
End If

On Error Resume Next

For i = lastrow To 1 Step -1
If .Cells(i, 3).Value = strTxt Then
.Range("C" & i).Offset(1).Resize(2).EntireRow.Insert shift:=xlDown
.Range("C" & i).Offset(2).Value = "me"
.Range("C" & i).Offset(1).Value = "Help"
End If
Next i

End With

Application.ScreenUpdating = True


End Sub

 

[dubmartian]

In that case try this

Sub Insert_Rows()

Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long
Dim strTxt As String

Application.ScreenUpdating = False

lastrow = Cells(Rows.Count, "C").End(xlUp).Row


strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.")

If Len(strTxt) < 1 Then
MsgBox "You must enter a text string consisting of at least one character"
Exit Sub
End If

With ActiveSheet

lngCount = Application.WorksheetFunction.CountIf(.Range("C1:C" & lastrow), strTxt)

If lngCount < 1 Then
MsgBox "The text string you entered is not listed - cancelling", vbExclamation
Exit Sub
End If

On Error Resume Next

For i = lastrow To 1 Step -1
If .Cells(i, 3).Value = strTxt Then
.Range("C" & i).Offset(1).Resize(2).EntireRow.Insert shift:=xlDown
.Range("C" & i).Offset(2).Value = "me"
.Range("C" & i).Offset(1).Value = "Help"
End If
Next i

End With

Application.ScreenUpdating = True


End Sub

Ok I see that, awesome.
Would I be correct in assuming that if I wanted the offset text to appear in col D I would just need to change the range to D from C ?

The data presented me changed, I now need to search col d and if I find a text string that matches, insert 2 rows sheet wide and add the text into the new rows specifically col c.

 

[Fluff]

Would I be correct in assuming that if I wanted the offset text to appear in col D I would just need to change the range to D from C ?

That's right

 

[dubmartian]

That's right

Thank you,

I am checking now on the changes

 

[dubmartian]

Everything works with the changes.
Last question, i have found that my cells contain a lot of text but when I try to find the one it doesn't find anything. is there a way of making it search all the text of the cell fod find a specific word versus not finding it because there is more that that text ?

 

[Fluff]

Give this a go

Sub Insert_Rows()

Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long
Dim strTxt As String

Application.ScreenUpdating = False

lastrow = Cells(Rows.Count, "C").End(xlUp).Row


strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.")

If Len(strTxt) < 1 Then
MsgBox "You must enter a text string consisting of at least one character"
Exit Sub
End If

With ActiveSheet

lngCount = Application.WorksheetFunction.CountIf(.Range("C1:C" & lastrow), "*" & strTxt & "*")

If lngCount < 1 Then
MsgBox "The text string you entered is not listed - cancelling", vbExclamation
Exit Sub
End If

On Error Resume Next

For i = lastrow To 1 Step -1
If .Cells(i, 3).Value Like "*" & strTxt & "*" Then
.Range("C" & i).Offset(1).Resize(2).EntireRow.Insert shift:=xlDown
.Range("C" & i).Offset(2).Value = "me"
.Range("C" & i).Offset(1).Value = "Help"
End If
Next i

End With

Application.ScreenUpdating = True


End Sub

 

[dubmartian]

Give this a go

Sub Insert_Rows()

Dim i As Long, lRows As Long, lastrow As Long, lngCount As Long
Dim strTxt As String

Application.ScreenUpdating = False

lastrow = Cells(Rows.Count, "C").End(xlUp).Row


strTxt = Application.InputBox("Enter the text string to search on. Rows will be inserted below each cell containing this string.")

If Len(strTxt) < 1 Then
MsgBox "You must enter a text string consisting of at least one character"
Exit Sub
End If

With ActiveSheet

lngCount = Application.WorksheetFunction.CountIf(.Range("C1:C" & lastrow), "*" & strTxt & "*")

If lngCount < 1 Then
MsgBox "The text string you entered is not listed - cancelling", vbExclamation
Exit Sub
End If

On Error Resume Next

For i = lastrow To 1 Step -1
If .Cells(i, 3).Value Like "*" & strTxt & "*" Then
.Range("C" & i).Offset(1).Resize(2).EntireRow.Insert shift:=xlDown
.Range("C" & i).Offset(2).Value = "me"
.Range("C" & i).Offset(1).Value = "Help"
End If
Next i

End With

Application.ScreenUpdating = True


End Sub

This is perfect thank you kindly for you help