Excel VBA send to email address by looking for header "Email" and sending email to first cell beneath matching header

Question

I'm looking send to specific email addresses by looking for header "Email" and then sending email to first cell beneath matching header. the email address column is not always the same which is why i need it to return the cell beneath (which is where the email address is, eg email header ak1-email address ak2) once it matches.

[Excel文件示例][1][1]：https://i.stack.imgur.com/dKybj.png

我想用可以查找 header（第 1 行）并插入对应的 email 地址（单个单元格，第 2 行）的东西替换我的代码中的范围 AJ2

Range("AJ1").Select
ActiveCell.FormulaR1C1 = "Fund Email"


  'Move the active sheet to a new Workbook
ActiveWindow.SelectedSheets.Copy
ActiveWorkbook.Password = "**********"

ActiveWorkbook.SaveAs 
"\\na\Forrest\Backup.xlsx"
Dim OutApp As Object
Dim OutMail As Object
 Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = Range("AJ2").Value
    .CC = ""
    .BCC = ""
    .Subject = Range("AK2").Value + " -Benefits backup"
    .Body = "Attached is the current month's benefit payment backup for 
check en route to your fund's office."
    .Attachments.Add ActiveWorkbook.FullName
            .send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

ActiveWorkbook.Close

Answer 1

Dim cel as Range
Dim dst as String       ' Destinataire
Dim sbj as String       ' Subject 

Const FEM = "fund email"  
Range("AJ1").Value = FEM 

ActiveWorkbook.Password = "BlahBlah"
ActiveWorkbook.SaveAs   = "\\na\Forrest\Backup.xlsx"

Set cel = Rows(1).Find(FEM)
sbj = cel.Offset(0,1).Value     '  "CBA"
dst = cel.Offset(1,0).Value     '  "Frank.Barone@usa.com"

On Error Resume Next ' Sends the current workbook by mail 
ActiveWorkbook.SendMail dst, sbj & " -Benefits backup - see Attachment."  
' Unfortunately you cannot fill the body of the mail with this method
On Error GoTo 0

' etc ...