私が現在仕事で使っているマクロを以下に記載します。メラーはOutlook Express です。マクロ作成方法等はご存知ですか？
Sub Send_Mail_With()
'****************************************************************
'あるリストを担当者ごとに分けて添付して担当者の電子メールに送る
'****************************************************************
'1-1. 準備
Current_Directory = ThisWorkbook.Path & "\"
Active_Book_Name = ActiveWorkbook.Name
Active_Sheet_Name = ActiveSheet.Name
Application.SheetsInNewWorkbook = 1 '<-- 作成するBookにあるシート数を１枚にする
Workbooks(Active_Book_Name).Worksheets(Active_Sheet_Name).Activate
'******************************************************************************************************
'1-2.電子メールの用意
Set objMS = CreateObject("CDO.Message")
objMS.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'SMTPサーバIPアドレス
objMS.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "XXX.XXX.XXX.XX"
'Type of authentication, NONE=0, Basic (Base64 encoded)=1, NTLM=2
objMS.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'電子メールアカウント名
objMS.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = "nnnnnn"
'電子メールパスワード
'objMS.Configuration.Fields.Item _
'("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "pppppp"
objMS.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMS.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
objMS.Configuration.Fields.Update
'******************************************************************************************************
'2. 担当者(列P)、客先(列B)、業者(列D)ごとに並べ替え
Worksheets("あるリスト").Activate
ActiveSheet.AutoFilterMode = False
Range(Cells(1, 1), Cells(Cells(1, 2).End(xlDown).Row, 31)).Sort Key1:=Range("P2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, Key3:=Range("D2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
'3. 特別なメッセージを入力する。
Special_Message = InputBox("特別なメッセージがあれば入力してください", vbOKCancel)
'4. 担当者が変わるまで読み込み、各担当者のシートを作る
pgyou = 2
rgyou = 2
Do Until Cells(rgyou, 2) = ""
If Cells(rgyou, 16) <> Cells(rgyou + 1, 16) Then '担当者が次行と同じか？
'4-1.担当者名シート追加
page_mei = Cells(rgyou, 16)
Worksheets.Add.Name = page_mei
Worksheets(page_mei).Move After:=Worksheets(Worksheets.Count)
'4-2.ヘッダーをコピー
Worksheets("あるリスト").Rows(1).Copy
Worksheets(page_mei).Rows(1).Select
ActiveSheet.Paste
'4-3.値をコピー
Worksheets("あるリスト").Activate
Range(Cells(pgyou, 1), Cells(rgyou, 30)).Copy
Worksheets(page_mei).Activate
Cells(2, 1).Select
ActiveSheet.Paste
pgyou = rgyou + 1
End If
rgyou = rgyou + 1
Worksheets("あるリスト").Activate
Loop
'6. 担当者が変わったら新しいBookを作る
rgyou = 2
Workbooks(Active_Book_Name).Worksheets("あるリスト").Activate
Do Until Cells(rgyou, 2) = ""
Cells(rgyou, 16).Select
If Cells(rgyou, 16) <> Cells(rgyou + 1, 16) Then
tantousha = Cells(rgyou, 16)
New_File_Name = "リスト(" & tantousha & "分).xls"
Full_File_Name = Current_Directory & New_File_Name
If Dir(Full_File_Name) <> "" Then
Kill (Full_File_Name)
End If
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Full_File_Name
Workbooks(Active_Book_Name).Worksheets(tantousha).Activate
Cells.Copy
Workbooks(New_File_Name).Activate
Cells.PasteSpecial
Workbooks(New_File_Name).Save
Workbooks(New_File_Name).Close
Workbooks(Active_Book_Name).Worksheets(tantousha).Activate
'7. Book を担当者電子メールに添付して送る
To_Address = Trim(Cells(2, 28).Value)
ans = MsgBox(To_Address, vbYesNo)
If ans = vbNo Then GoTo TUGI
'常時送るCCの人
Cc_Address = "bbbbb@kkkkk.co.jp;"
objMS.attachments.DeleteAll '前の添付をクリアしないと追加になってしまう
objMS.To = To_Address
If Trim(Cc_Address) <> "" Then objMS.Cc = Cc_Address
objMS.From = "suzuki@urbancom.co.jp"
objMS.Subject = "シート貴殿の分"
teikei = "今月のシートです" & vbCrLf _
If Special_Message <> "" Then
objMS.TextBody = teikei & Special_Message & vbCrLf & Now
Else
objMS.TextBody = teikei & Now
End If
objMS.AddAttachment Full_File_Name
objMS.Send
End If
'8. 次の担当者分を処理
TUGI:
Workbooks(Active_Book_Name).Worksheets(Active_Sheet_Name).Activate
rgyou = rgyou + 1
Loop
Set objMS = Nothing
End Sub
お礼
ああ・・・詳述なご回答を頂けてました。 不慣れなものでなぜか締め切ったあとにAlpha-jさんの詳述なマクロ例を発見しました・・・＞＜ さっそく頂いたご回答をもとに実施してみます！
補足
レスありがとうございます。 すっかり質問した日より日数がたってしまいました＞＜ 申し訳ありません。 じつはまだ着手しておらず・・・とほほ。 いったん質問を締めさせてもらいます。 どうもありがとうございました。