发送拆分工作簿的每个新工作簿

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