Excel VBA : find PTS01 and do things in loop

BW1997

New Member
Joined
Feb 13, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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)

1581619259460.png


After the macro has run it should look like this;

1581619441587.png


I hope someone can help me with my request.

Thanks in advance,
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Hi and welcome to MrExcel.

Just one detail, the data should start in row 2.
varios 13feb2020.xlsm
A
1HEAD
2001-PTS01
3001-PTS02
4001-PTS03
5001-PTS01
6001-PTS01
7001-PTS02
8001-PTS03
Sheet


Try this:

VBA Code:
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
 
Upvote 0
Hey Dante,

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

1581664176907.png



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


Result:

1581664379654.png


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

Also thanks in advance to help me!
 
Upvote 0
Hey Dante,

Sorry my mistake.

Before the macro:
1581694837343.png


after macro:

1581694979683.png


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


Thank you in advance !
 
Upvote 0
Try this please:

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,496
Messages
6,113,995
Members
448,539
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top