Macro to find name in header and put in word in column below header matching the number of rows in another column

[tropics123]

I'm trying to get the macro to look for "Mary Lee" in header (row 1) and puts in the word "LOAN" below it. It should go all the way down to match the number of rows in column A. The name "Mary Lee" may appear multiple times in the header. Data will change daily, so the number of rows in Column A will change.

This is what the macro is currently doing. It stopped after finding "Mary Lee" the first time and overrode her name. Macro is at the bottom. Thanks for your help!

Column A	Column B Mary LeeLOAN	Column C Luke Skywalker	Column D Mary Lee	Column E Bob Smith	Column F Mary Lee	Column G Joe Watson
2/5/19	LOAN	$90				$23
3/15/19	LOAN	$19				$587
5/15/19		$35				$6560

<tbody>
</tbody>

Desired result:

Column A	Column B Mary Lee	Column C Luke Skywalker	Column D Mary Lee	Column E Bob Smith	Column F Mary Lee	Column G Joe Watson
2/5/19	LOAN	$90	LOAN		LOAN	$23
3/15/19	LOAN	$19	LOAN		LOAN	$587
5/15/19	LOAN	$35	LOAN		LOAN	$6560

<tbody>
</tbody>

Borrowed some of this macro idea from JoeMo

Sub AddinWordLOAN()


Sheets("Sheet3").Select


Dim tgtHdrs As Variant, Fnd As Range, fAdr As String
Dim LastRow As Long
tgtHdrs = Array("Mary Lee") 'Look for name "Mary Lee" in the header row 1 and put in the word LOAN below it
Application.ScreenUpdating = False
For i = LBound(tgtHdrs) To UBound(tgtHdrs)
Set Fnd = Rows(1).Find(what:=tgtHdrs(i), lookat:=xlWhole, MatchCase:=False)
If Not Fnd Is Nothing Then
fAdr = Fnd.Address
End If
Do
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range(Fnd.Offset(2, 0), Cells(Rows.Count, Fnd.Column).End(xlUp)).Value = "LOAN" 'the word LOAN should go all the way down to match number of rows in column A
Set Fnd = Rows(1).FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
If Fnd.Address = fAdr Then Exit Do
Loop
Next i
Application.ScreenUpdating = True
End Sub

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG28Jun25
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Col [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = ActiveSheet.Range("A1").CurrentRegion

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Col [COLOR="Navy"]In[/COLOR] Rng.Rows(1).Cells
    [COLOR="Navy"]If[/COLOR] Col.Value = "Mary Lee" [COLOR="Navy"]Then[/COLOR]
        Col.Offset(1).Resize(Rng.Rows.Count - 1) = "Loan"
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Col
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[tropics123]

That worked PERFECTLY and the macro was so clean looking! Absolutely amazing! Thank you so much!!!!!

 

[MickG]

You're welcome