人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルのマクロの質問です。マクロで通常使用しているメール送信ソフトを立ち上げることは可能でしょうか?(Outlookではありません)
来店客の購入履歴を「来店記録」、会員登録してもらった顧客情報を「顧客名簿」というファイルに記録しており、来店した顧客にサンクスメールを送っています。
現在は「来店記録」の会員番号から「顧客名簿」を検索し、該当する顧客のメールを新規作成したメールの宛先欄に入力。件名、顧客名、定型文のヘッダーとフッター、担当者名を本文にコピ&ペーストし、業務的になり過ぎないよう、一言添えて送信しています。
作業が面倒なため送ったり送らなかったりしています。これをマクロで自動化できればと考えています。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のためサンプルデータ、仕様の詳細はこの下にある「この質問・回答へのコメント」に記載いたします。

●質問者: icta
●カテゴリ:コンピュータ
✍キーワード:Outlook エクセル コメント コード サンクス
○ 状態 :終了
└ 回答数 : 5/5件

▽最新の回答へ

1 ● airplant
●20ポイント

詳細なマクロは、何度もやり取りをされているようなので、ポイントのみを回答します。


マクロがなくても、担当者名やメールアドレスがあれば、次のように、mailtoでできます(Outlookで確認。他メーラーは、個別に確認してみてください。「%0D%A」がうまくいかないケースあるかも)。

送信ボタンのところの「メール送信」をクリックすると、予め作られたテンプレートが出てくるので、そこへ一文入れて送信ボタンを押せば送信されます。


A B C D E
1 顧客名 メールアドレス 担当 送信ボタン 本文
2 佐藤 satoh@hoge.ne.jp 田中 =HYPERLINK("mailto:" & A2 & " <" & B2 & ">?subject=" & "お買い上げありがとうございます" & "&cc=" & "tanaka@marumaru.com" & "&body=" & E2, "メール送信") =A2&"様" & "%0D%0A" & "こんにちは、○○店の" & C2 & "です。%0D%0A" & "このたびはお買い上げいただき誠にありがとうございました。%0D%0A%0D%0A%0D%0A" & "それでは今後ともよろしくお願いいたします。%0D%0A○○店 " & C2

上記の例では、固定値を直接書いていますが、それだとExcelファイルが大きくなるので、名前をつけて、そこへ固定のテキストを入れておけば大丈夫です。

参考→ http://d.hatena.ne.jp/airplant/20070808/1186598203


マクロ化するのであれば、送信ボタンのところをExcelのセルへ入れるだけですね。


2 ● SALINGER
●0ポイント

使っているメールソフトを使う場合、mailtoでリンクを作れば楽なので

airplantさんの回答を参考にして、仕様変更して来店記録に送信ボタンをつけるマクロを作ってみました。

来店記録に後ろのほうの空いている列に、「送信リンク」「メール」「一言」「本文」の列を追加することはできるでしょうか。

できれば、4つの見出しを作ってください。

以下のマクロは作った見出しの列にairplantさんの送信リンクを一括して設定するマクロです。

メールを送信するときは、一言に記入してメール送信をクリックするだけなので、

かなり作業が簡略化されると思います。

Sub AddMailRetu()
 Application.ScreenUpdating = False
 Dim RMidasiName(8) As String
 Dim RMidasiCol(8) As Integer
 Dim KMidasiName(2) As String
 Dim KMidasiCol(2) As Integer
 Dim Rsaisyuretu As Long
 Dim Usaisyuretu As Long
 Dim Ksaisyuretu As Long
 Dim StartDay As Date
 Dim EndDay As Date
 Dim jyouiNum As Integer
 
 Const YourMail As String = "tanaka@marumaru.com"  '送信者のメールアドレス
 
  '作業用変数
 Dim i As Integer
 Dim j As Long
 Dim k As Integer
 Dim r As Range
 Dim f As Boolean

 Dim wr As Worksheet  '来店記録シート
 Dim wk As Worksheet  '顧客名簿シート

 Set wr = Worksheets("来店記録")
 Set wk = Worksheets("顧客名簿")

 RMidasiName(0) = "会員番号"
 RMidasiName(1) = "名前"
 RMidasiName(2) = "担当"
 RMidasiName(3) = "送信リンク"
 RMidasiName(4) = "メール"
 RMidasiName(5) = "一言"
 RMidasiName(6) = "本文"
 RMidasiName(7) = "店舗"

 KMidasiName(0) = "会員番号"
 KMidasiName(1) = "メール"
 
 Usaisyuretu = 5
 
  '来店記録の列の位置を取得
 For i = 0 To 7
 Set r = wr.Rows(1).Find(what:=RMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に" & RMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 RMidasiCol(i) = r.Column
 Next i
 
  '顧客名簿の列の位置を取得
 For i = 0 To 1
 Set r = wk.Rows(1).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に" & KMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 KMidasiCol(i) = r.Column
 Next i

  '来店記録の最終行の取得
 Rsaisyuretu = wr.Cells(65536, RMidasiCol(0)).End(xlUp).Row
  '顧客管理の最終行の取得
 Ksaisyuretu = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row

 For i = 2 To Rsaisyuretu
 For j = 2 To Ksaisyuretu
 wr.Cells(i, RMidasiCol(3)).Formula = "=HYPERLINK(""mailto:"" & " & _
 wr.Cells(i, RMidasiCol(1)).Address & " & "" <"" & " & wr.Cells(i, RMidasiCol(4)).Address & _
 " & "">?subject="" & ""お買い上げありがとうございます"" & ""&cc="" & """ & YourMail & _
 """ & ""&body="" & " & wr.Cells(i, RMidasiCol(6)).Address & ", ""メール送信"")"
 wr.Cells(i, RMidasiCol(6)).Formula = "=" & wr.Cells(i, RMidasiCol(1)).Address & _
 "&""様"" & ""%0D%0A"" & ""こんにちは、"" & " & wr.Cells(i, RMidasiCol(7)).Address & _
 " & ""店の"" & " & wr.Cells(i, RMidasiCol(2)).Address & _
 " & ""です。%0D%0A"" & ""このたびはお買い上げいただき誠にありがとうございました。" & _
 "%0D%0A"" & " & wr.Cells(i, RMidasiCol(5)).Address & _
 " & ""%0D%0A"" & ""それでは今後ともよろしくお願いいたします。%0D%0A"" & " & _
 wr.Cells(i, RMidasiCol(7)).Address & " & ""店 "" & " & wr.Cells(i, RMidasiCol(2)).Address & ""
 If wr.Cells(i, RMidasiCol(0)).Value = wk.Cells(j, KMidasiCol(0)).Value Then
 wr.Cells(i, RMidasiCol(4)).Value = wk.Cells(j, KMidasiCol(1)).Value
 End If
 
 Next j
 Next i
End Sub

3 ● SALINGER
●0ポイント

前回回答したものは、違う回答を転用して書いたのでいろいろ無駄なコードがあったことをお詫びします。

ほぼご希望のコードができたと思うので回答します。

作業列ではなく1行目の最終セルを作業セルとして使いました。メール後は削除されます。

Sub AddMailRetu()
 Application.ScreenUpdating = False
 Dim RMidasiName(4) As String
 Dim RMidasiCol(4) As Integer
 Dim KMidasiName(2) As String
 Dim KMidasiCol(2) As Integer
 Dim Rsaisyuretu As Long
 Dim Ksaisyuretu As Long
 Dim sendAddress As String
 Dim honbun As String
 Dim kenmei As String
 Dim sr As Long
 Dim sv As String
 
 Const YourMail As String = "tanaka@marumaru.com"  '送信者のメールアドレス
 
  '作業用変数
 Dim i As Long
 Dim j As Long
 Dim r As Range

 Dim wr As Worksheet  '来店記録シート
 Dim wk As Worksheet  '顧客名簿シート

 Set wr = Worksheets("来店記録")
 Set wk = Worksheets("顧客名簿")

 RMidasiName(0) = "会員番号"
 RMidasiName(1) = "名前"
 RMidasiName(2) = "担当"
 RMidasiName(3) = "店舗"

 KMidasiName(0) = "会員番号"
 KMidasiName(1) = "メール"
 
  '来店記録の列の位置を取得
 For i = 0 To 3
 Set r = wr.Rows(1).Find(what:=RMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に" & RMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 RMidasiCol(i) = r.Column
 Next i
 
  '顧客名簿の列の位置を取得
 For i = 0 To 1
 Set r = wk.Rows(1).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に" & KMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 KMidasiCol(i) = r.Column
 Next i

  '会員番号が選択されているかをチェック
 If Selection.Column = RMidasiCol(0) And Selection.Value <> "" Then
 sr = Selection.Row
 sv = Selection.Value
 Else
 MsgBox "会員番号を選択して実行してください"
 Exit Sub
 End If
 
  '顧客管理の最終行の取得
 Ksaisyuretu = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row

  'メール情報の取得
 honbun = wr.Cells(sr, RMidasiCol(1)).Value & "様%0D%0Aこんにちは、" & _
 wr.Cells(sr, RMidasiCol(3)).Value & "店の" & wr.Cells(sr, RMidasiCol(2)).Value & _
 "です。%0D%0Aこのたびはお買い上げいただき誠にありがとうございました。" & _
 "%0D%0A%0D%0Aそれでは今後ともよろしくお願いいたします。%0D%0A" & _
 wr.Cells(sr, RMidasiCol(3)).Value & "店 " & wr.Cells(sr, RMidasiCol(2)).Value
 kenmei = "お買い上げありがとうございます"
 For j = 2 To Ksaisyuretu
 If wk.Cells(j, KMidasiCol(0)).Value = sv Then
 sendAddress = wk.Cells(j, KMidasiCol(1)).Value
 Exit For
 End If
 Next j
 
  'メールの送信
 wr.Hyperlinks.Add(Anchor:=Range("IV1"), _
 Address:="mailto:" & sendAddress & "?subject=" & kenmei & _
 "&body=" & honbun & "&cc=" & YourMail).Follow
 Range("IV1").ClearContents
 
 Application.ScreenUpdating = True
End Sub

4 ● SALINGER
●0ポイント

コメントの3点の修正しました。

Sub AddMailRetu()
 Application.ScreenUpdating = False
 Dim RMidasiName(4) As String
 Dim RMidasiCol(4) As Integer
 Dim KMidasiName(2) As String
 Dim KMidasiCol(2) As Integer
 Dim Rsaisyuretu As Long
 Dim Ksaisyuretu As Long
 Dim sendAddress As String
 Dim honbun As String
 Dim kenmei As String
 Dim sr As Long
 Dim sv As String
 
  '作業用変数
 Dim i As Long
 Dim j As Long
 Dim r As Range

 Dim wr As Worksheet  '来店記録シート
 Dim wk As Worksheet  '顧客名簿シート

 Set wr = Worksheets("来店記録")
 Set wk = Worksheets("顧客名簿")

 RMidasiName(0) = "会員番号"
 RMidasiName(1) = "名前"
 RMidasiName(2) = "担当"
 RMidasiName(3) = "店舗"

 KMidasiName(0) = "会員番号"
 KMidasiName(1) = "メール"
 
  '来店記録の列の位置を取得
 For i = 0 To 3
 Set r = wr.Rows(1).Find(what:=RMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に" & RMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 RMidasiCol(i) = r.Column
 Next i
 
  '顧客名簿の列の位置を取得
 For i = 0 To 1
 Set r = wk.Rows(1).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に" & KMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 KMidasiCol(i) = r.Column
 Next i

  '会員番号が選択されているかをチェック
 If Selection.Column = RMidasiCol(0) And Selection.Value <> "" Then
 sr = Selection.Row
 sv = Selection.Value
 Else
 MsgBox "会員番号を選択して実行してください"
 Exit Sub
 End If
 
  '顧客管理の最終行の取得
 Ksaisyuretu = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row

  'メール情報の取得
 honbun = wr.Cells(sr, RMidasiCol(1)).Value & "様%0D%0Aこんにちは、" & _
 wr.Cells(sr, RMidasiCol(3)).Value & "店の" & wr.Cells(sr, RMidasiCol(2)).Value & _
 "です。%0D%0Aこのたびはお買い上げいただき誠にありがとうございました。" & _
 "%0D%0A%0D%0Aそれでは今後ともよろしくお願いいたします。%0D%0A" & _
 wr.Cells(sr, RMidasiCol(3)).Value & "店 " & wr.Cells(sr, RMidasiCol(2)).Value
 kenmei = "お買い上げありがとうございます"
 For j = 2 To Ksaisyuretu
 If wk.Cells(j, KMidasiCol(0)).Value = sv Then
 sendAddress = wk.Cells(j, KMidasiCol(1)).Value
 Exit For
 End If
 Next j
 
  'メールの送信
 If sendAddress <> "" Then
 sendAddress = wr.Cells(sr, RMidasiCol(1)).Value & "<" & sendAddress & ">"
 wr.Hyperlinks.Add(Anchor:=Range("IV1"), _
 Address:="mailto:" & sendAddress & "?subject=" & kenmei & "&body=" & honbun).Follow
 Range("IV1").ClearContents
 Else
 MsgBox "メールの登録がありません。"
 End If
 Application.ScreenUpdating = True
End Sub

5 ● SALINGER
●1500ポイント ベストアンサー

お仕事終わってからの、回答のチェックご苦労様です。

会員番号が無かったとき、「メールの登録がありません」と表示していましたが、

「該当する会員番号がありません」になるように、勝手に機能を足しておきました。

Sub AddMailRetu()
 Application.ScreenUpdating = False
 
  '管理ブックのパスを環境に合わせてください
 Const myPath As String = "C:\管理"
  '顧客管理のブック名
 Const wbName As String = "顧客管理.xls"
  '顧客名簿のワークシート名
 Const wsName As String = "顧客名簿"
 
 Dim RMidasiName(4) As String
 Dim RMidasiCol(4) As Integer
 Dim KMidasiName(2) As String
 Dim KMidasiCol(2) As Integer
 Dim Rsaisyuretu As Long
 Dim Ksaisyuretu As Long
 Dim sendAddress As String
 Dim honbun As String
 Dim kenmei As String
 Dim sr As Long
 Dim sv As String
 
  '作業用変数
 Dim i As Long
 Dim j As Long
 Dim r As Range
 Dim f As Boolean

 Dim wr As Worksheet  '来店記録シート
 Dim wk As Worksheet  '顧客名簿シート

 Set wr = Worksheets("来店記録")

 RMidasiName(0) = "会員番号"
 RMidasiName(1) = "名前"
 RMidasiName(2) = "担当"
 RMidasiName(3) = "店舗"

 KMidasiName(0) = "会員番号"
 KMidasiName(1) = "メール"
 
  '来店記録の列の位置を取得
 For i = 0 To 3
 Set r = wr.Rows(1).Find(what:=RMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "来店記録に" & RMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 RMidasiCol(i) = r.Column
 Next i
 
  '会員番号が選択されているかをチェック
 If Selection.Column = RMidasiCol(0) And Selection.Value <> "" Then
 sr = Selection.Row
 sv = Selection.Value
 Else
 MsgBox "会員番号を選択して実行してください"
 Exit Sub
 End If
 
  '顧客管理を開く
 On Error GoTo err_Trp
 If bookCheck(myPath & "\" & wbName) Then
 Set wk = Workbooks(wbName).Worksheets(wsName)
 Else
 Set wk = Workbooks.Open(myPath & "\" & wbName).Worksheets(wsName)
 End If
 On Error GoTo 0
 
  '顧客名簿の列の位置を取得
 For i = 0 To 1
 Set r = wk.Rows(1).Find(what:=KMidasiName(i), lookat:=xlWhole)
 If r Is Nothing Then
 MsgBox "顧客名簿に" & KMidasiName(i) & "の列名は存在しません。検索場所を確認してください。"
 Exit Sub
 End If
 KMidasiCol(i) = r.Column
 Next i

 
  '顧客管理の最終行の取得
 Ksaisyuretu = wk.Cells(65536, KMidasiCol(0)).End(xlUp).Row

  'メール情報の取得
 honbun = wr.Cells(sr, RMidasiCol(1)).Value & "様%0D%0Aこんにちは、" & _
 wr.Cells(sr, RMidasiCol(3)).Value & "店の" & wr.Cells(sr, RMidasiCol(2)).Value & _
 "です。%0D%0Aこのたびはお買い上げいただき誠にありがとうございました。" & _
 "%0D%0A%0D%0Aそれでは今後ともよろしくお願いいたします。%0D%0A" & _
 wr.Cells(sr, RMidasiCol(3)).Value & "店 " & wr.Cells(sr, RMidasiCol(2)).Value
 kenmei = "お買い上げありがとうございます"
 f = False
 For j = 2 To Ksaisyuretu
 If wk.Cells(j, KMidasiCol(0)).Value = sv Then
 sendAddress = wk.Cells(j, KMidasiCol(1)).Value
 f = True
 Exit For
 End If
 Next j
 
  'メールの送信
 If f Then
 If sendAddress <> "" Then
 sendAddress = wr.Cells(sr, RMidasiCol(1)).Value & "<" & sendAddress & ">"
 wr.Hyperlinks.Add(Anchor:=Range("IV1"), _
 Address:="mailto:" & sendAddress & "?subject=" & kenmei & "&body=" & honbun).Follow
 Range("IV1").ClearContents
 Else
 MsgBox "メールの登録がありません。"
 End If
 Else
 MsgBox "該当する会員番号がありません"
 End If
 
 Application.ScreenUpdating = True
 
 Application.DisplayAlerts = False
 Workbooks(wbName).Close
 Application.DisplayAlerts = True
 
 Exit Sub
 
err_Trp:
 Select Case Err.Number
 Case 1004
 MsgBox "顧客管理ブックをオープンできません。パスを確認してください。"
 Case 9
 MsgBox "顧客名簿の正しいブック名とシート名を指定してください。"
 Case Else
 MsgBox "顧客管理をオープンすることができませんでした。"
 End Select
 Application.ScreenUpdating = True
End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
 Dim f As Boolean
 Dim myBook As Workbook
 For Each myBook In Workbooks
 If myBook.Path & "\" & myBook.Name = myPath Then
 f = True
 Exit For
 End If
 Next
 bookCheck = f
End Function
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ