Question

我有基于条件分割工作簿的代码。我想将这些新工作簿中的每一个都发送给不同的人。

当我运行宏时，它会拆分工作簿并将所有工作表放在我想要的位置。当我尝试发送时，我只发送1封电子邮件。

Sub savesheetsSend()

Dim ws As Worksheet
Dim Filetype As String
Dim Filenum As Long
Dim wb As Workbook
Dim FolderName As String
Dim open_book As Workbook
Set outmail = CreateObject("outlook.application")
Set outmsg = outmail.createitem(0)

Set wb = Application.ThisWorkbook

'create directory to save each sheet in
FolderName = "C:\Users\jpenn\Desktop" & "\" & wb.Name
MkDir FolderName

On Error Resume Next

'save each sheet as workbook in directory
For Each ws In wb.Worksheets

    If ws.Range("A1") = 1 Then
        Filetype = ".xlsm": Filenum = 52
        ws.Copy
        xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & Filetype
        Application.ActiveWorkbook.SaveAs xFile, FileFormat:=Filenum
    End If
Next

'send all new workbooks to email address in CELL("B1")
For Each open_book In Application.Workbooks
    If open_book.Name <> ThisWorkbook.Name Then

        With outmsg
            .Subject = ActiveWorkbook.Name & " payroll data"
            .To = ActiveWorkbook.ActiveSheet.Range("b1").Value
            .body = "I will get to this later"
            .Attachments.Add Application.ActiveWorkbook.FullName
            .send
        End With
    open_book.Close
    End If
Next

End Sub

Answer 1

以这种方式试试......经过测试

Option Explicit
Sub savesheetsSend()
    Dim Ws As Worksheet
    Dim Filetype As String
    Dim xFile As String
    Dim Filenum As Long
    Dim Wb As Workbook
    Dim FolderName As String
    Dim Open_Book As Workbook
    Dim OutMsg As Object
    Dim OutMail As Object

    Set OutMail = CreateObject("outlook.application")
    Set Wb = Application.ThisWorkbook

    'create directory to save each sheet in
    FolderName = "C:\Users\jpenn\Desktop" & "\" & Wb.Name
    MkDir FolderName

    'save each sheet as workbook in directory
    For Each Ws In Wb.Worksheets

        If Ws.Range("A1") = 1 Then
            Filetype = ".xlsm": Filenum = 52
            Ws.Copy
            xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & Filetype
            Application.ActiveWorkbook.SaveAs xFile, FileFormat:=Filenum

            Set OutMsg = OutMail.createitem(0)

            With OutMsg
                .Subject = Ws.Name & " payroll data"
                .To = ActiveSheet.Range("b1").Value
                .Body = "I will get to this later"
                .Attachments.Add (xFile)
                .Display
            End With

            ActiveWorkbook.Close

        End If
    Next
End Sub

通过电子邮件发送拆分工作簿的每个新工作簿

1 个答案: