Insert rows (1 to 4) if the cell value equals a fixed word.

[Guest]

I am looking for a macro to run once the fixed word in cell A13 for example
equals to “Health†and after the macro found the that cell will insert 1 to 3
rows and writing the following;
Cell A14 = “Health group A†--- This should be first row to be inserted
Cell A15 = “Health group B†--- This should be 2nd row to be inserted
Cell A16 = “Health group C†--- This should be 3rd row to inserted.
And than the macro should also read the information in Cell B13 and copy it
in B14 where the first row has been inserted and so on till the last row.

A B C D E
13 Health 110 1101 11011 100
14 Health group A 110 1101 11011 100
15 Health group B 110 1101 11011 100
16 Health group C 110 1101 11011 100

Any help will be very much appreciated.

 

[Guest]

Assuming you actually mean any cell in column A that contains the word Health
and A13 was an example of one such cell, then run this macro:

Sub abc()
Dim lastrow As Long, i As Long, j As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = lastrow To 1 Step -1
If LCase(Cells(i, 1).Value) = "health" Then
Cells(i, 1).Offset(1, 0).Resize(3, 1).EntireRow.Insert
Cells(i, 1).Offset(0, 1).Resize(4, 4).FillDown
For j = 1 To 3
Cells(i + j, "A").Value = "Health Group " & Chr(j + 64)
Next j
End If
Next i

End Sub