VBA - Loop macro with Offset

[JoeRooney]

Hi,

Wondering if anyone could help with a loop macro I am tryingto build

My plan is to Find the text 0004 , once found cut the cellsfrom column R àYand paste 1 row up into column Z

Next I need to find the text 0005 , once found cut the cellsfrom column RàY and paste 2 rows up intocolumn AH.

I know how to use a search and find and a offset macro butunsure on how to join the 2 together.

Any help is greatly appreciated.

Thanks

 

[Yongle]

Adapt this to your needs

BEFORE
Excel 2016 (Windows) 32 bit

	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​	L​	M​	N​	O​	P​	Q​	R​	S​	T​	U​	V​	W​	X​	Y​	Z​	AA​	AB​	AC​	AD​	AE​	AF​	AG​	AH​
1​																		1​
2​																		2​
3​	xx																	3​
4​	text 005																	4​
5​	xx																	5​
6​	xx																	6​
7​	xx																	7​
8​	text 005																	8​
9​	xx																	9​
10​	xx																	10​
11​	xx																	11​
12​	xx																	12​
13​	dd																	13​
14​	dd																	14​
15​	text 004																	15​
16​	text 004																	16​
17​	tt																	17​
18​	tt																	18​
19​	tt																	19​
20​	tt																	20​

Sheet: Text004

AFTER

Excel 2016 (Windows) 32 bit

	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​	L​	M​	N​	O​	P​	Q​	R​	S​	T​	U​	V​	W​	X​	Y​	Z​	AA​	AB​	AC​	AD​	AE​	AF​	AG​	AH​
1​																		1​
2​																		2​																4​
3​	xx																	3​
4​	text 005
5​	xx																	5​
6​	xx																	6​																8​
7​	xx																	7​
8​	text 005
9​	xx																	9​
10​	xx																	10​
11​	xx																	11​
12​	xx																	12​
13​	dd																	13​
14​	dd																	14​								15​
15​	text 004																									16​
16​	text 004
17​	tt																	17​
18​	tt																	18​
19​	tt																	19​
20​	tt																	20​

Sheet: Text004

The code needs adapting to suit your needs
- let me know f you need help

The sub calls the function which identifies all the cells that match the text
VBA looks in Column A for text 004 and moves the contents of column R ( to row above in column Z )
VBA looks in Column A for text 005 and moves the contents of column R (to row that is 2 rows above in column AH)
The search is not case sensitive
The search is matching the value in the whole cell

Sub FindAndCut()
    Dim cel As Range
On Error Resume Next
        For Each cel In GetRng("text 004", Range("A:A"))
            If Err.Number > 0 Then Exit For                 '[COLOR=#006400]required in case nothing is found[/COLOR]
            Cells(cel.Row, "R").Cut Cells(cel.Row - 1, "Z")
        Next
On Error GoTo 0
On Error Resume Next
        For Each cel In GetRng("text 005", Range("A:A"))
            If Err.Number > 0 Then Exit For               [COLOR=#006400]   'required in case nothing is found[/COLOR]
            Cells(cel.Row, "R").Cut Cells(cel.Row - 2, "AH")
        Next
On Error GoTo 0
End Sub

Function GetRng(findWhat As String, lookWhere As Range) As Range
    Dim rng As Range, addr1 As String
    Set rng = lookWhere.Find(findWhat, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
    If Not rng Is Nothing Then
        addr1 = rng.Address
        Set GetRng = rng
        Do
            Set GetRng = Union(GetRng, rng)
            Set rng = lookWhere.FindNext(rng)
        Loop Until rng Is Nothing Or rng.Address = addr1
    End If
End Function

 

[JoeRooney]

That's Perfect , Thank you

 

[Yongle]

thanks for your feedback