Excel VBA : find PTS01 and do things in loop

[BW1997]

Dear beloved VBA enthousiasts,

I've already tried my best to program the following macro on my own. I think my request is just too hard for me at this moment (because I've just recently discovered Excel VBA).

My request is the following:

So the macro must find a certain word (for example "PTS01") in the first column.
After the macro has found the PTS01 is has to insert 3 rows below the found "PTS01" and merge the 3 rows below the found word including the word "PTS01".
It also has to merge the 4 rows right next to "PTS01" (second colulm)
Then it has to insert some text like: test1 in column 3.
test2
Test 3
test 4

This all need to be done in a loop so it finds all the words and does the exact same proces for all the found "PTS01" words.

I've tried to program it on my own but I've never got further than inserting 3 rows below a highlighted word and merging all the cells beside them.
(this is a basic program so I think it has no point in posting this here)

First this is what is inserted in the excel; (start before running macro)

After the macro has run it should look like this;

I hope someone can help me with my request.

Thanks in advance,

 

[DanteAmor]

Hi and welcome to MrExcel.

Just one detail, the data should start in row 2.

varios 13feb2020.xlsm
	A
1	HEAD
2	001-PTS01
3	001-PTS02
4	001-PTS03
5	001-PTS01
6	001-PTS01
7	001-PTS02
8	001-PTS03
Sheet

Try this:

Sub Find_PTS01()
  Dim  r As Range, f As Range, cell As String
  Application.ScreenUpdating = False
  Set r = Range("A:A")
  Set f = r.Find("PTS01", , xlValues, xlPart, , xlNext, False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      f.Offset(1).Resize(3).Insert xlDown, xlFormatFromLeftOrAbove
      f.Resize(4).Merge
      f.Offset(, 1).Resize(4).Merge
      f.Offset(, 2).Resize(4).Value = Application.Transpose(Array("test1", "test2", "test3", "test4"))
    Set f = r.FindNext(f)
    Loop While Not f Is Nothing And f.Address <> cell
  End If
End Sub

 

[BW1997]

Hey Dante,

The excel works fine thank you.
Just one problem I'm having.
Forget to mention there is also data in column B.

After I run the macro:
2 or 3 times same pop up shows:

Result:

As you can see the text in column B shifts up. This should be prevented.

Also thanks in advance to help me!

 

[DanteAmor]

As you can see the text in column B shifts up. This should be prevented.

Yes it is a detail that you forgot to mention. So how do you want the result?

 

[BW1997]

Hey Dante,

Sorry my mistake.

Before the macro:

after macro:

So the info under HEAD INFO shouldn't shift if you know what I mean.


Thank you in advance !

 

[DanteAmor]

Try this please:

Sub Find_PTS01()
  Dim r As Range, f As Range, cell As String
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set r = Range("A:A")
  Set f = r.Find("PTS01", , xlValues, xlPart, , xlNext, False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      f.Offset(1).Resize(3).EntireRow.Insert xlDown, xlFormatFromLeftOrAbove
      f.Resize(4).Merge
      f.Offset(, 1).Resize(4).Merge
      f.Offset(, 2).Resize(4).Value = Application.Transpose(Array("test1", "test2", "test3", "test4"))
      Set f = r.FindNext(f)
    Loop While Not f Is Nothing And f.Address <> cell
  End If
End Sub