急求好心人帮忙修改一个VBA， （现在的运行不了）

dhsDAS

我有一个VBA想实现自定义把一个excel不同tabs以附件形式发送出去
比如一个excel有10个标签页：1, C1000, C2000, C3000, C4000, C5000, C6000, C7000, C8000, C9000
1.        我可以自定义不同标签页和送给谁
           "C1000, C2000", "John.Smith1@abccbacbacba.com"
           "C3000, C4000, C5000", "John.Smith2@abccbacbacba.com"
           "C6000", "John.Smith3@abccbacbacba.com"
           "C7000, C8000, C9000", "John.Smith4@abccbacbacba.com"
2.        我运行以后，
A．        标签页C1000和C2000会从原excel分离出来， 合并成一个单独excel，文件名是John.Smith1， 作为附件发送给John.Smith1@abccbacbacba.com
B．        标签页C300，C4000和C5000会从原excel分离出来， 合并成一个单独excel，文件名是John.Smith3， 作为附件发送给John.Smith1@abccbacbacba.com
C．        标签页C6000从原excel分离出来， 成一个单独excel，文件名是John.Smith3， 作为附件发送给John.Smith3@abccbacbacba.com
D．        标签页C700，C8000和C9000会从原excel分离出来， 合并成一个单独excel，文件名是John.Smith4， 作为附件发送给John.Smith4@abccbacbacba.com
E．        VBA 不处理标签页“1”

我上传了一个附件， 麻烦您帮我修改一下，（现在VBA运行停在 “"outMail.Attachments.Add attachmentPath"”）
----------------------------------

约定的童话

难度不大，没有附件不好处理，一下仅供参考：

Sub SendEmail()
    '定义变量
    Dim MySheet As Worksheet
    Dim MyRange As Range
    Dim EmailAddress As String
    Dim FileName As String
   
    '设置参数
    Set MySheet = ThisWorkbook.Sheets("Sheet1") '请替换为您的工作表名称
    EmailAddress = "john.smith@abccbacbacba.com" '请替换为您的电子邮件地址
    FileName = "John.Smith" & ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row & ".xlsx" '请替换为您要发送的文件名
   
    '获取标签页范围
    Set MyRange = MySheet.Range("C1:C1000") '请替换为您的标签页范围，例如C1:C1000
   
    '分离每个标签页并保存为单独的Excel文件
    Dim i As Long
    For i = MyRange.Rows.Count To 1 Step -1
        If MyRange.Cells(i, "A").Value <> "" Then
            With Application.FileDialog(msoFileDialogFolderPicker)
                .Title = "选择要保存的工作簿"
                .Show
                If .SelectedItems.Count > 0 Then
                    With Workbooks.Open(.SelectedItems(1))
                        MySheet.Copy After:=Workbooks(.SelectedItems(1)).Sheets(1)
                        .SaveAs Filename:=FileName, FileFormat:=xlOpenXMLWorkbook
                        ActiveSheet.Delete
                        ActiveSheet.Name = "Sheet1"
                        .Close SaveChanges:=False
                    End With
                End If
            End With
        End If
    Next i
   
    '创建邮件对象并设置收件人、主题和正文
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")
    Dim OutMail As Object
    Set OutMail = OutApp.CreateItem(0)
    OutMail.To = EmailAddress '请替换为您的电子邮件地址
    OutMail.Subject = "Excel工作表分离为附件" '请替换为您的邮件主题
    MsgBox "附件已发送。",vbInformation,"提示" '显示发送成功的消息框
   
    '删除临时工作表并释放内存
    MySheet.Delete False '删除临时工作表，但保留工作簿中的所有数据和格式
End Sub

dhsDAS

非常感谢你的帮助。

但是这个好像不能自定义把几个标签页合成一个文件发出去？ 比如我想自定义： 两个标签页C1000, C2000 合成一个文件发给A， 三个标签页 C3000, C4000, C5000 合成一个文件发给B

dhsDAS

约定的童话 发表于 2023-5-13 12:17
难度不大，没有附件不好处理，一下仅供参考：

Sub SendEmail()

非常感谢你的帮助。

但是这个好像不能自定义把几个标签页合成一个文件发出去？ 比如我想自定义： 两个标签页C1000, C2000 合成一个文件发给A， 三个标签页 C3000, C4000, C5000 合成一个文件发给B

danielchen1225

我用VBA写过一个完全一样的功能，自动发送邮件这个问题不大。
难点1是对邮件中的多个邮件地址进行有效的拆分---实现了群发多人邮件---搞定了；
难点2，你指的标签页应该是要指定特定的几个worksheet 作为邮件附件进行发送；通过特定单元格对应特定的worksheet进行判断---搞定了
建议你上传附件。可以帮您尝试修改下

wfywc81

用chatGPT写了一段代码，详见附件，看是否能满足需求。

dhsDAS

danielchen1225 发表于 2023-5-13 22:29
我用VBA写过一个完全一样的功能，自动发送邮件这个问题不大。
难点1是对邮件中的多个邮件地址进行有效的拆 ...

我上传了那个excel到主题帖， 谢谢大家帮我看看。

dhsDAS

wfywc81 发表于 2023-5-14 02:01
用chatGPT写了一段代码，详见附件，看是否能满足需求。

谢谢。 这个似乎是不能发送邮件， chatGPT也没有设置哪几个标签页发送给谁

dhsDAS

哪位帮忙看看吧， 谢谢了。

dhsDAS

哪位帮忙看看吧， 谢谢了。