エクセルのマクロの質問です。マクロで通常使用しているメール送信ソフトを立ち上げることは可能でしょうか?(Outlookではありません)

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

回答の条件
  • 1人10回まで
  • 登録:2008/06/08 04:53:33
  • 終了:2008/06/11 15:28:50

ベストアンサー

id:SALINGER No.5

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/11 01:07:06

ポイント1500pt

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

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

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

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

その他の回答(4件)

id:airplant No.1

airplant回答回数220ベストアンサー獲得回数492008/06/08 12:36:13

ポイント20pt

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


マクロがなくても、担当者名やメールアドレスがあれば、次のように、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のセルへ入れるだけですね。

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/09 01:09:46

使っているメールソフトを使う場合、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
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/09 10:31:18

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

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

作業列ではなく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
id:SALINGER No.4

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/09 20:25:08

コメントの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
id:SALINGER No.5

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/11 01:07:06ここでベストアンサー

ポイント1500pt

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

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

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

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
  • id:icta
    このマクロを利用するのはエクセルの知識がほとんどない販売スタッフです。
    そのため極力簡単なステップで該当するデータを作成したいと思います。
    お知恵とお力をお借りできれば幸いです。
    仕様で何かご不明な点ありましたらお知らせください。


    ■マクロの仕様

    ○概要
    ※「来店記録」シートの"会員番号"列のセルを選択しマクロを実行。その行の"担当"列を変数tantouに保存。
    ※「顧客名簿」シートの"会員番号"列から上記の会員番号を探し出し、その行の"名前"列を変数namaeに保存。
    ※「顧客名簿」シートから該当する会員番号の"名前"列の顧客名と"メール"列の顧客メールを「顧客名 <顧客メール>」の形にしてメーラーの宛先に挿入する。
    ※マクロ内に以下のように設定できるようにしておき、本文に挿入する。
    ・件名
     「お買い上げありがとうございます」
    ・本文
     「"namae"様
      こんにちは、○○店の"tantou"です。
      このたびはお買い上げいただき誠にありがとうございました。
      ~一言添える空白行~
      それでは今後ともよろしくお願いいたします。
      ○○店"tantou"」
    ※マクロ終了。
    ※業務的になり過ぎないよう、空白行に一言添えて送信する。

    ○詳細
    ※「来店記録」シートは3万行超である
    ※「来店記録」シート、「顧客名簿」シートは2つとも「顧客管理.xls」ブック内にある。
    ※「来店記録」シート、「顧客名簿」シートはタイトル行が1行目に存在する。
    ※サンプルデータはいくつかのデータ列を省略。そのため「来店記録」シート9番目の列が"担当"として定まってはいない。タイトル行を列名で検索し該当する列名を調査対象とする。
    ※メーラーは既定のメーラーとして登録されているものを開く。Outlookではない。
    ※「顧客名 <顧客メール>」とするのは送信した顧客を名前で確認できるようにするためである。


    ■サンプルデータ(タブ区切り)

    ○「来店記録」シート/顧客の購入履歴を記載
    連番 店舗 会員番号 旧会員番号 会員資格 名前 フリガナ 来店日 担当 売上
    30506 渋谷 T01187 1187 正 大森 オオモリ 2008/4/28 佐藤 5000
    30505 渋谷 T00583 583 仮 村上 ムラカミ 2008/5/3 田中 15000

    ○「顧客名簿」シート/顧客情報を記載
    連番 会員番号 旧会員番号 会員資格 名前 フリガナ 郵便番号 住所 電話番号 メール
    2 T00583 583 仮 村上 ムラカミ 180-XXXX 東京都XXXX 090XXXX aaa@bbb.com


    ■実際の運用
    ※「来店記録」シートの2行目"T00583"を選択しマクロを実行。担当の"田中"を変数tantouに保存。
    ・「顧客名簿」シートのタイトル行から"会員番号"と一致する列、"会員番号"列を探し出す。
    ・「顧客名簿」シートの"会員番号"列から"T00583"を探し出す。
    ・顧客名簿」シートから"T00583"と一致する行の"名前"列の"村上"と"メール"列の"aaa@bbb.com"を「村上 <aaa@bbb.com>」の形にしてメーラーの宛先に挿入する。
    ・件名と本文に次のように挿入する。
     件名
     「お買い上げありがとうございます」
     本文
     「村上様  
      こんにちは、○○店の田中です。
      このたびはお買い上げいただき誠にありがとうございました。
        ~一言添える空白行~
        それでは今後ともよろしくお願いいたします。
      ○○店田中」
    ※マクロ終了。
  • id:taknt
    起動するだけだったら簡単だけど、メールソフトもわからないのに いろいろ細かいことをして 送信なんて できない。
    しかも複数のメールソフトだったら なおさら。

    せめて Outlookのみ といえば、話は まだ簡単だが。

    >業務的になり過ぎないよう、空白行に一言添えて送信する。

    業務的になり過ぎないようというのは、従業員に指導する内容であって
    そんなことを マクロにしてくれというのは 無理 でしょう。
    毎回
    「それでは今後ともよろしくお願いいたします。」
    でいいのならば、それを 付与する だけでいいかと思うが。

    あと きちんと送信されたかどうかを確認するために BCCに 質問者のメアドを 入れたらいいと思うな。

  • id:icta
    > airplantさん

    ご回答ありがとうございます。
    確かにこの方法でメーラーを立ち上げ、定型文を送ることはできます。
    しかし、私の理解不足でしたら申し訳ないのですが、現在のメールをコピーしてメーラーに貼り付ける方法と比較して作業が増えているような気がします。
    それは次の点です。
    ・名前をつけて、そこへ固定のテキストを入れておく。
    ・「顧客名簿」シートは顧客の情報のみ。担当者の名前はない。担当者は「来店記録」シートにある。
    ・新しい顧客が追加されたら"送信ボタン”列の値と”本文”列の値をその都度増やさなければならない。
    ・「顧客名簿」は1万行近くあり、使用するPCはスペックの低いものばかりなので、数式があると動作が遅くなる。
    ・定型文の内容を簡単に変えられない。

    先のコメントに以下のように書きましたようにスキルのないスタッフにはこの方法は難しいと思われます。
    「このマクロを利用するのはエクセルの知識がほとんどない販売スタッフです。
    そのため極力簡単なステップで該当するデータを作成したいと思います。」

    もしこの作業方法について私が何か思い違いをしていましたらご指摘ください。
  • id:icta
    > SALINGERさん
    ご回答ありがとうございます。
    > 来店記録に後ろのほうの空いている列に、「送信リンク」「メール」「一言」「本文」の列を追加することはできるでしょうか。
    残念ながら後ろの列はSALINGERさんに作っていただいたhttp://q.hatena.ne.jp/1210860623のマクロでバーコードで入寮された商品番号を取り込むために空けておく必要があります。
    マクロを実行してみたのですが、▼以下の行で止まったまま動かなくなってしまいました。
    If wr.Cells(i, RMidasiCol(0)).Value = wk.Cells(j, KMidasiCol(0)).Value Then

    もしかしたらこの方法は、送信リンク、メール、一言、本文を入力したり、コピーしたりする必要が生じるのでしょうか?
    何かを「来店記録」シートに書き込んだりする方法はできるだけ避けたいと考えています。
    「来店記録」シートは3万行を超えており、オートフィルタが常時付いているため、数式が入っていると動作が重くなります。
    また計算方法を手動してスピードを遅くしないようにしても今度は別のファイルが常時数式が更新されないことになってしまいます。

    「通常使用しているメール送信ソフト」と指定しているのは理由があります。
    以前業者から導入したものがWEB上に送信フォームを作り、そこ入力させるものでした。
    見慣れない方法に抵抗があったようでスタッフが使うことはありませんでした。
    そのためこのような指定をすることにしました。
    いつも使っているメーラーなら安心して使えるし、送信履歴も残るからです。

    なお定型文に一言添えるのはエクセルではなく、メーラーで起動した新規メールの中で行いたいと思います。
    一言と言ってもスタッフや顧客次第で長い行数になることがあるからです。

    今回のマクロは「来店記録」シートに記載された顧客の会員番号上でマクロを実行すると宛先、名前、件名、本文(定型文)、顧客名、担当名が自動的に挿入されるというものをイメージしています。
    エクセルの顧客名簿からサンクスメールを送るという作業はよくありそうな状況なのでいろいろ検索してみましたが、有益な情報を探すことができませんでした。
    ダメ元で聞いてみましたので、もし「不可能」ということがわかればそれはそれで安心できます。
    もし「不可能」そうでしたら教えてください。よろしくお願いいたします。
  • id:SALINGER
    すいません。いつも詰が甘くてご迷惑をかけます。
    最初の方の
    '作業用変数
    Dim i As Integer

    Dim i As Long
    に変更してください。
    それと最後のループが間違ってました。
    下から18行目の
    For j = 2 To Ksaisyuretu
    の行が、下から7行目の位置に来ないといけませんでした。最後のほうは
        For j = 2 To Ksaisyuretu
          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
    となります。
    数式が使えない件理解しました。良い方法を考えてみます。最悪、本文だけでも自動生成してペーストするという方法ならできそうですが。
  • id:SALINGER
    新たに回答しましたので上の変更は必要なくなりました。
  • id:icta
    > SALINGERさん
    早々のご回答ありがとうございます。
    希望通りの動作を確認いたしました。
    前のコメントで「できない」と書いている方もいましたが私自身も最初からできると思っておらず、ダメ元の質問だったので希望通りの動作をしたときには本当にビックリしました。
    SALINGERさんのスキルとマクロの柔軟性に感服いたしました。
    ほとんど希望通りの動作なのですが、あと数点だけ機能を取り込んでいただくことは可能でしょうか。
    以下の3点です。

    ○メールが存在しないとき
    お店で会員登録した顧客はメールを持っていないことがあります。
    この場合、”メールの登録がありません。”というメッセージを表示し、マクロを中断することは可能でしょうか。

    ○メールを「顧客名 <顧客メール>」の形にする
    メールをこの形にするとメーラーの宛先に顧客名が入ります。
    後で見直した時、メールそのものより顧客名の方が認識しやすくなります。
    メールをこの形にすることは可能でしょうか。
     仕様
     「顧客名簿」シートから該当する会員番号の"名前"列の顧客名と"メール"列の顧客メールを「顧客名 <顧客メール>」の形にしてメーラーの宛先に挿入する。
     例:村上 <aaa@bbb.com>

    ○CCの削除
    メーラーのCC欄にtanaka@marumaru.comと入れていただいたのですが、これはairplantさんの回答にあったもので、特に必要ありません。
    仕様から外していただければ幸いです。

    お手すきの時にチェックしてみていただければ幸いです。

  • id:airplant
    1の回答を書いたairplantです。
    >・名前をつけて、そこへ固定のテキストを入れておく。
    >・「顧客名簿」シートは顧客の情報のみ。担当者の名前はない。担当者は「来店記録」シート

    これらの詳細は、全部見ないと分からないので、「ポイント」のみを記載しました(回答が中々なかったので・・・)。
    なお、これらの作業を行うのは、一般ユーザではなく、管理者(ictaさん?)を想定しています(テンプレートなりを作っておいて、ボタンを押せば数式を出す程度)。

    すべてをマクロでやらなくても、本の少しの数式だけでもできますよというサンプルです。
    後はSALINGERさんや他の方へお任せします。

    でも、これだけ色々なものを作られるなら、今後のためにある程度覚えられたほうがいいと思いますよ。
  • id:icta
    > airplantさん

    > 今後のためにある程度覚えられたほうがいいと思いますよ。
    実に心痛いお言葉です。
    エクセルでマクロを使い始めて13年以上になります。頑張って覚えてやっとここまで来ました。
    これでも「ある程度」まで覚えたつもりでした。
    数学や機械モノに強い人にはなかなか判ってもらえないかもしれませんが、どんなに本を買ったり調べたりしても「この程度」なのです。
    プログラミングは絵を描くのと同じようにセンスだと思います。
    センスがないとどんなに長い間勉強しても「ある程度」すら身に付かないものだと実感しております。

    > SALINGERさん

    早々のご回答ありがとうございました。
    これで完璧です。
    スタッフに見せたら「すごい!」と感嘆の声を上げておりました。
    早速今日から運用と思ったのですが、肝心なことを仕様に書くのを忘れておりました。
    それはメールを送るときに限り、顧客の来店情報が「顧客管理.xls」の「来店記録」シートにないということです。
    どういうことかというと、エクセルに不慣れな複数の人間が「顧客管理.xls」に直接入力するとデータを改竄、削除してしまったりする怖れがあります。
    そうした事態を避けるために次の方法を採っています。
    ・各店舗は「顧客管理.xls」の「来店記録」シートに直接書き込めない。
    ・各店舗は「転記.xls」の「来店記録」シートに毎日入力する。
    ・本店の多少スキルのあるスタッフを担当者に定め、翌日各店舗から送られた「転記.xls」の「来店記録」シートを合体する。

    サンクスメールを送るのは購入日当日です。
    そのため「転記.xls」の「来店記録」シートから「顧客管理.xls」の「顧客名簿」シートを参照しに行く必要があります。
    後からの仕様変更で大変申し訳ないのですがこの1点だけを取り込んでいただくことは可能でしょうか?
    毎回仕様の変更ばかりで心苦しい限りです。
    お手すきの時にチェックしていただければ幸いです。
  • id:icta
    > SALINGERさん

    早々のご回答ありがとございます。
    早速試してみました。
    うまく行っているように見えたのですが、色々テストしてみると▼次の点でおかしな動作が出てしまいます。
    ○「顧客管理.xls」がマクロ終了後に閉じてしまう。
    「転記.xls」の「来店記録」シートでマクロを実行すると、メーラーが立ち上がり、マクロが終了すると、「顧客管理.xls」が勝手に閉じられてしまいます。
    これは仕様かもしれませんが「顧客管理.xls」は常時開いておくのでマクロを実行しても閉じないようにしていただけるとありがたいです。

    ○「顧客管理.xls」の「来店記録」シートでマクロを実行することもある。
    普段はサンクスメールを当日中に出しますが、何らかの原因で翌日回しになることもあります。
    その場合は「顧客管理.xls」の「来店記録」シートからマクロを実行します。
    現在は「顧客管理.xls」の”会員番号”列でマクロを実行すると会員番号を選択してマクロを実行してくださいというエラーメッセージが表示されます。
    「会員番号」列、「旧会員番号」列では同じメッセージが出て、マクロがストップするだけですが、「会員資格」列で行うと同じメッセージが出た後、「顧客管理.xls」が上のように勝手に閉じられてしまいます。
    「顧客管理.xls」の「来店記録」シートでもサンクスメールを同じように送るようにすることは可能でしょうか?

    何度もお手数をおかけして申し訳ありませんが、お手すきの時にチェックしていただければ幸いです。
  • id:SALINGER
    スタッフは顧客管理.xlsに直接書き込まないということだったので、自動的に顧客管理は閉じるようにしたのですが。
    Application.DisplayAlerts = False
    Workbooks(wbName).Close
    Application.DisplayAlerts = True
    下のほうのこの3行を削除してください。
    後半の不具合は私の環境では起きず、同じシート内でも普通に使えます。
  • id:icta
    > SALINGERさん

    早々のご回答ありがとうございました。
    完全に期待通りの動作を確認できました。
    3行分を削除したら両方の問題が解決しました。

    早速本日から使い始めることにします。
    マクロでエクセルから定型文を普段のメーラーで開けるのは本当に便利です。
    店舗や通販を運営するものにとっては大幅な効率アップになります。
    本当にありがとうございました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません