EXCELの一部のシートのみを添付ファイルとしてメール送信する方法？

質問

EXCELでシートのみを添付ファイルとしてメール送信する方法を考えています。
シート「１」、シート「２」・・・シート「３０」

といったような構成のEXCELブックがあり、
さらにシート「メール送信」というシートを設け、
そのシートのみを添付ファイルとしてメール送信する方法です。

BASP、SendMailメソッド、アドイン、いろいろな方策は見当たりましたが、
なかなか「シートのみを添付ファイルで送信」といったような実例が見当たらず困ってしまっています。
やはりVBAで考えるのが早いでしょうか？
もしVBAでやるとすれば、みなさんならばどういったものになるのかぜひ教えてください。
その他、いい方策があれば教えて頂きたいです。

具体的なイメージとしてはこうです。

シート「メール送信」のA1セルにシート「５」のA1セル（売上）をリンク
シート「メール送信」のB1セルあたりにコマンドボタン「メールを送信する」
添付されるシートには数式ではなく、値としてデータが挿入されている

といったような運用方法です

回答No.1

Alpha-j · ベストアンサー

私が現在仕事で使っているマクロを以下に記載します。メラーは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

回答No.2

Alpha-j

o_olllsig さん
マクロは完成しましたか?

お礼

ああ・・・詳述なご回答を頂けてました。
不慣れなものでなぜか締め切ったあとにAlpha-jさんの詳述なマクロ例を発見しました・・・＞＜

さっそく頂いたご回答をもとに実施してみます！

補足

レスありがとうございます。
すっかり質問した日より日数がたってしまいました＞＜
申し訳ありません。
じつはまだ着手しておらず・・・とほほ。

いったん質問を締めさせてもらいます。
どうもありがとうございました。