Excel 从列中的列表返回电子邮件地址

我有一个开源的Excel VBA电子邮件代码，它将工作簿中的所有工作表保存到一个文件中，然后打开Outlook并将该文件作为单个附件添加到各个Outlook电子邮件中

未正确输入电子邮件“收件人：”地址

假设工作簿中有10个工作表。
表1是主工作表，其中列出了所有单独的记录。
表2-10包含主工作表中的单个记录

此代码将错误地将Sheet1（主控）附加到Outlook，并且Sheet2的电子邮件地址位于“收件人”字段中。Sheet1不需要通过电子邮件发送。 其余的工作表附加到Outlook，没有“收件人”地址

前两行是标题。
列A包含名称。
B列包含电子邮件地址。
其余的列包含数据

Sub-Split_To_工作簿_和_电子邮件（）
Dim FileExtStr作为字符串
Dim FileFormatNum尽可能长
将Sourcewb设置为工作簿
将WB设置为工作簿
将sh设置为工作表
将日期字符串设置为字符串
Dim FolderName作为字符串
看起来像物体的暗淡的肌肉
将myMailItem设置为对象
将我的主题设置为字符串
将myPath设置为字符串
作为对象的Dim otlApp
应用
.ScreenUpdate=False
.EnableEvents=False
.Calculation=xlCalculationManual
以
'提示输入电子邮件主题
设置otlApp=CreateObject（“Outlook.Application”）
mySubject=InputBox（“电子邮件主题”）
'使用此宏复制工作簿中的每张工作表
设置Sourcewb=ActiveWorkbook
'创建新文件夹以在其中保存新文件
DateString=格式（现在为“yyyy-mm-dd-hh-mm-ss”）
FolderName=“C:\Temp\email\u students\”&Sourcewb.Name&&&DateString
MkDir FolderName
'将每个可见工作表复制到新工作簿
对于Sourcewb.工作表中的每个sh
'如果工作表可见，则将其复制到新工作簿
如果sh.Visible=-1，则
sh.副本
'将Destwb设置为新工作簿
设置Destwb=ActiveWorkbook
'确定Excel版本和文件扩展名/格式
用Destwb
如果Val（Application.Version）<12，则
“您使用的是Excel 97-2003
FileExtStr=“.xls”：FileFormatNum=-4143
其他的
“您使用的是Excel 2007-2016
如果Sourcewb.Name=.Name，则
MsgBox“您的答案在安全对话框中为否”
转到转到下一页
其他的
FileExtStr=“.xlsx”：FileFormatNum=51
如果结束
如果结束
以
'如果需要，请将工作表中的所有单元格更改为值
如果Destwb.Sheets（1）.ProtectContents=False，则
与Destwb.Sheets（1）一起使用
.细胞，复制
.Cells.paste特殊XLPaste值
.单元格（1）。选择
以
Application.CutCopyMode=False
如果结束
'保存新工作簿，发送电子邮件，然后关闭它
设置otlNewMail=otlApp.CreateItem（olMailItem）
用Destwb
.SaveAs FolderName_
&“\”&Destwb.Sheets（1）.Name&FileExtStr_
FileFormat:=FileFormatNum
以
SDest=“”
对于iCounter=3的工作表function.CountA（列（2））
如果SDest=”“，则
SDest=单元格（iCounter，2）。值
”“否则呢
'SDest=SDest&“；”&单元格（iCounter，1）。值
如果结束
下一个iCounter
myPath=ActiveWorkbook.Path&“\”&ActiveWorkbook.Name
用Destwb
.关闭错误
以
用otlNewMail
.to=SDest
.Subject=mySubject
.Body=“*在此处输入电子邮件。*”
.Attachments.Add myPath
.展示
以
设置otlNewMail=Nothing
如果结束
GoToNextSheet：
下一个sh
MsgBox“您可以在”&FolderName中找到文件
应用
.ScreenUpdate=True
.EnableEvents=True
.Calculation=xlcalculation自动
以
端接头

我把它修好了。我更改了“For Each”以查找电子邮件地址，取消了“For iCounter”循环，并将“For Each”中的值添加到“to:”字段中。现在效果很好。以下是最终代码：

Sub Split_To_Workbook_and_Email()
'Working in 2013/2016
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim myOutlook As Object
    Dim myMailItem As Object
    Dim mySubject As String
    Dim myPath As String
    Dim otlApp As Object
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    'Prompt for Email Subject
    
    Set otlApp = CreateObject("Outlook.Application")
    mySubject = InputBox("Subject for Email")
    
    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "C:\Temp\email_students\" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        If sh.Range("B3").Value Like "?*@?*.?*" Then
            sh.Copy
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
            'Determine the Excel version and file extension/format
             FileExtStr = ".xlsx": FileFormatNum = 51
                   
         End If
           
            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it
            Set otlNewMail = otlApp.CreateItem(olMailItem)
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
            End With
            
                              
            
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            With Destwb
                .Close False
            End With
            With otlNewMail
                .To = sh.Range("B3").Value 'email address location
                .Subject = mySubject
                .Body = "Enter body code here."
                .Attachments.Add myPath
                .Display
            End With
            
            Set otlNewMail = Nothing
        
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    End Sub

---

如果sh.Visible=-1和sh.Name“Sheet1”，则使用此选项，以便忽略
Sheet1
，并且不会首先复制。感谢@Siddharth Rout让code忽略第一张图纸。