Searching for headings and inserting rows

[ksak]

This is my code:

Sub Insertrow()
Dim ADF As Variant
ADF = Range("D2")

Selection.Find(What:=ADF, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate _
.EntireRow.Insert shift:=xlDown

End Sub

I highlight the entire column B (Selection) because that's where i want the macro to do the searching. It looks for what I type in cell D2 which is my variant. the code works up until this point. What i need help with is having the code insert an entire row underneath the row with the heading i specified in D2.

Please help!

 

[Weaver]

try:

Sub insertRow2()
    Dim ADF As Variant
    ADF = Range("D2").Value
    Cells.Find(what:=ADF, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).EntireRow.Insert shift:=xlDown
End Sub

I'm thinking though that if the activecell is before D2 in the sheet, then all this code is going to do is find D2 then insert a row below this cell.

 

[ksak]

Thanks! what you mentioned won't be an issue because D2 is at the top of the sheet with all of the data below it.

Minor tweak though if possible. Right now it inserts rows above the heading it finds. anyway to insert rows below? i already tried "Insert shift:=xlUp"

 

[Weaver]

Thanks! what you mentioned won't be an issue because D2 is at the top of the sheet with all of the data below it.

Minor tweak though if possible. Right now it inserts rows above the heading it finds. anyway to insert rows below? i already tried "Insert shift:=xlUp"

I think if you move the reference down a line by using offset

Cells.Find(what:=ADF, After:=ActiveCell, LookIn:=xlValues, _
 LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
 MatchCase:=False, SearchFormat:=False)[B][COLOR=red].offset(1,0)[/COLOR][/B].EntireRow.Insert shift:=xlDown

 

[ksak]

The above definitely worked thank you! So this is what I have so far:

Sub Insertrow()
Dim ADF As Variant

ADF = Range("D2")

Range("B:B").Select
Selection.Find(What:=ADF, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(1, 0).EntireRow.Insert shift:=xlDown

Range("D1").Copy
Selection.Find(What:=ADF, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub

It basically searches for a word, inserts a row beneath that word. however i have blocks of similar information repeating itself and i would like this macro to loop until it stops finding the first word. can someone help me out with the loop function?