【Excel VBA】定型メールをボタン1つで作成する手段を考える話。

毎日、仕事でメールを書いています。

顧客情報（Webページ）をコピペして、その説明を書いて、何回かチェックして送信、…
という流れなのですが、頭の回転が遅いのとケアレスミスでやり直すのとで結構時間を食います。そして無駄にイライラする…

そうこうしているうちにお客様もお待たせしてしまうし、誤開示なんてことになったら…
と考えると良いことがありません。

そもそもコピペ部分はシステムでどうにかして欲しいのですが笑、なかなかそうもいかず。
少しでも頭を使う時間を確保するためにExcelの力を借りてみました。

シートの作成イメージ
コード
ちょっとだけ補足します
参照
まとめ
注釈

シートの作成イメージ

AAA不動産から、BBBカンパニーに何やら不穏な会合のお知らせをお届け、という設定（仮）。

※画像はイメージです。 f:id:yuricks7:20181111180953p:plain

まず、定型的な項目に絞って入力項目を考えます（A列）。
B列にその内容を記入すると、D列のExcel関数でメール本文が作成されます。

作成後、D1セルにあるこれを格納ボタンを押すとD列の文章が
クリップボードに格納されるので、それを貼り付けて送信、という寸法です。

コード

D1セルのボタンに設定するコードは以下の通りです。

Option Explicit

'=======================
'【1】格納するセルの範囲を設定
'=======================
Public Sub setVariableForInfoMail()

    Const FIRST_ROW As Long = 2
    Const LAST_ROW As Long = 23

    Dim TARGET_COL As Long = 4

    Call storeIntoClipboard(FIRST_ROW, LAST_ROW, TARGET_COL)

End Sub

'F列で内容の違うメールを作成して、F1セルにもボタンを作る
Public Sub setVariableForAskMail()

    Const FIRST_ROW As Long = 2
    Const LAST_ROW As Long = 7

    Dim TARGET_COL As Long = 6

    Call storeIntoClipboard(FIRST_ROW, LAST_ROW, TARGET_COL)

End Sub

'=======================
'【2】連結した文字列をクリップボードに格納する（メイン）
'=======================
'事前にライブラリの参照設定をしておく。
'ユーザーフォームの 追加 > 削除 でok。
'ライブラリ名：【Microsoft Forms 2.0 Object Library】
Private Sub storeIntoClipboard(ByVal firstRow As Long, _
                               ByVal lastRow As Long, _
                               ByVal targetCol As Long)

    Dim ThisSheet As Worksheet
    Set ThisSheet = ThisWorkbook.ActiveSheet

    Dim tmpStrings As String
    tmpStrings = joinStrings(ThisSheet, firstRow, lastRow, targetCol)

    With New MSForms.DataObject
        .SetText tmpStrings<br>'変数の値をDataObjectに格納する
        .PutInClipboard<br>'DataObjectのデータをクリップボードに格納する
    End With
    
    '参考としてH列に連結結果を出力
    Const OUTPUT_COL As Long = 8
    ThisSheet.Paste Destination:=ThisSheet.Cells(firstRow, OUTPUT_COL)
    
    MsgBox "格納しました。" & vbCrLf & _
                "一旦メモ帳に貼り付けてお使いください。"

End Sub

'=======================
'【3】文字列を連結する
'=======================
Private Function joinStrings(ByRef targetSheet As Worksheet, _
                             ByVal firstRow As Long, _
                             ByVal lastRow As Long, _
                             ByVal targetCol As Long) As String

    Dim results As String: results = targetSheet.Cells(firstRow, targetCol)
    
    Dim i As Long
    For i = firstRow + 1 To lastRow
        results = results & vbCrLf & targetSheet.Cells(i, targetCol)
    Next i

    joinStrings = results

End Function

ちょっとだけ補足します

【1】格納するセルの範囲を設定

ワークシートの列ごとに何パターンか定型文を用意するとして、
ボタンごとに格納する範囲を設定します。

Public Sub setVariableForInfoMail()

    Const FIRST_ROW As Long = 2
    Const LAST_ROW As Long = 23

    Dim TARGET_COL As Long = 4

    Call storeIntoClipboard(FIRST_ROW, LAST_ROW, TARGET_COL)

End Sub

※多分これは最終行の取得（苦手）でもう少し柔軟に変更できる気がします。。。

【2】連結した文字列をクリップボードに格納する

クリップボードにデータを格納するにあたり、データオブジェクトという
少し特殊な機能を使います。

ライブラリ一覧から探すのは数が多すぎてちょっとめんどくさいので笑、
ユーザーフォームをいったん追加して削除することで参照設定だけ適用します。

'事前にライブラリの参照設定をしておく。
'ユーザーフォームの 追加 > 削除 でok。
'ライブラリ名：【Microsoft Forms 2.0 Object Library】

'～～（中略）～～

    With New MSForms.DataObject
        .SetText tmpStrings<br>'変数の値をDataObjectに格納する
        .PutInClipboard<br>'DataObjectのデータをクリップボードに格納する
    End With

また、そのまま貼り付けすると文字化けを起こす*1ので、メモ帳などのエディタを経由して変換します。

    MsgBox "格納しました。" & vbCrLf & _
                "一旦メモ帳に貼り付けてお使いください。"

私のレベルと時間の関係で今回はやめましたが、これも本当はコードで解決すると思います。ADOオブジェクトとやらで…？

【3】文字列を連結する

文字列の連結と言ったらJoin関数と思ったのですが、連結対象を
範囲（二次元配列）で渡すので動いてくれませんでした。
配列を取り出して改行を足して文字列に…とか考えてたらよく分からなくなってしまいました。笑

<2018/01/05追記>
WorksheetFunction.TRANSPOSE関数というものを使うと、
二次元配列を一次元に直してくれるというコメントをいただきました。ありがとうございます！
詳しい説明は、頂いた下記リンクをご参照ください。
thom.hateblo.jp

というわけで、現状（未修正）は1行ずつ取り出して
手動でつなげる流れです。

Private Function joinStrings(ByRef targetSheet As Worksheet, _
                             ByVal firstRow As Long, _
                             ByVal lastRow As Long, _
                             ByVal targetCol As Long) As String

    Dim results As String: results = targetSheet.Cells(firstRow, targetCol)
    
    Dim i As Long
    For i = firstRow + 1 To lastRow
        results = results & vbCrLf & targetSheet.Cells(i, targetCol)
    Next i

    joinStrings = results

End Function