Macro to find a cell containing text, select range offset, cut and paste to lower row

[sdaniels]

I am trying to find a macro that can search a sheet for any cell that contains the text “Not on AOI,” selects a range that contains that cell, 81 rows below and all the data to the right, then cuts the selection and pastes it 162 rows below the original cell where the text was found.

For a simplified example, I want to take a sheet that looks like this:

NHA01	NHA01-Not on AOI	NHA04	NHA04	NHA04- Not on AOI	NHA07	NHA07	NHA07- Not on AOI
1	1	5	0	0	7	2	2

And make it look like:

NHA01
1
	NHA01-Not on AOI	NHA04	NHA04
	1	5	0
				NHA04- Not on AOI	NHA07	NHA07
				0	7	2
							NHA07- Not on AOI
							2

Notice the number of columns between “Not on AOI” is variable.

I’m very new to excel macros and the parts I think I’ve put together are:

Cells.Find("Not on AOI", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True).Activate

Range(ActiveCell,ActiveCell.Offset(81,2000)).Select
Selection.Cut
ActiveCell.Offset(162,0).Select
Selection.Paste

[Simi]

This seems to work based on the sample data you provided.

Sub simi_test()


Dim lTotalColumns As Long
Dim lCurrentColumn As Long
Dim lCurrentRow As Long


Dim iRowOffset As Integer
Dim iRowDest As Integer


Application.ScreenUpdating = False


lCurrentColumn = 1
lCurrentRow = 1


iRowOffset = 1  'change this value to however many rows under the header row you want to copy.
iRowDest = 2    'change this value to 1+ how many rows you want between the data in this example 2 will put 1 blank row between data


With ActiveSheet
    
    lTotalColumns = .Cells(1, .Columns.Count).End(xlToLeft).Column


    Do While lCurrentColumn <= lTotalColumns
        If InStr(1, .Cells(lCurrentRow, lCurrentColumn), "Not on AOI") > 0 Then
            .Range(.Cells(lCurrentRow, lCurrentColumn), .Cells(lCurrentRow + iRowOffset, lTotalColumns)).Copy
            .Range(.Cells(lCurrentRow + iRowOffset + iRowDest, lCurrentColumn), .Cells(lCurrentRow + iRowOffset + iRowOffset + iRowDest, lTotalColumns)).PasteSpecial Paste:=xlPasteAll
            .Range(.Cells(lCurrentRow, lCurrentColumn), .Cells(lCurrentRow + iRowOffset, lTotalColumns)).Clear
            lCurrentRow = lCurrentRow + iRowOffset + iRowDest
        End If
        lCurrentColumn = lCurrentColumn + 1
    Loop
    
    .Range("A1").Select
    
End With


Application.ScreenUpdating = True


End Sub

I added notes in the code for the places for you to change how many rows you want to copy and how many rows between the data you want.

[sdaniels]

Thank you so much! This works perfectly.