分割したブックの新しいブックをそれぞれメールで送信

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