Excel VBA通过查找标题"Email"并将电子邮件发送到匹配标题下的第一个单元格来发送到电子邮件地址

Question

我想通过查找标题来发送到特定的电子邮件地址"电子邮件"；然后将电子邮件发送到匹配标头下的第一个单元格。电子邮件地址列并不总是相同的，这就是为什么我需要它在匹配后返回下面的单元格(即电子邮件地址所在的位置，例如电子邮件标题ak1电子邮件地址ak2(。

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

我想用可以查找标题(第1行(并插入对应的电子邮件地址(单个单元格，第2行(的东西来替换代码中的AJ2范围

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

'Move the active sheet to a new Workbook
ActiveWindow.SelectedSheets.Copy
ActiveWorkbook.Password = "**********"
ActiveWorkbook.SaveAs 
"\naForrestBackup.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   = "\naForrestBackup.xlsx"
Set cel = Rows(1).Find(FEM)
sbj = cel.Offset(0,1).Value     '  "CBA"
dst = cel.Offset(1,0).Value     '  "[e-mail]"
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 ...