VBAで自動メール作成したいのとアクティブセルの行のある列の値を元に色々なセルの値を変数に代入したいです。

Question

![イメージ説明]### 実現したいこと
よろしくお願い致します。

添付画像は
1枚目：Sheet1
2枚目：Sheet2
3枚目：Debag.printでhonbunを表示した画像
4枚目：メール作成した際に必要な情報が本文に反映されていない画像
5枚目：本文セルにセルの値を参照しようとした画像

・自動でOutlookメールを作成したい
・1シート目のアクティブセルの行のある列の値を2シート目のある列の中から探したい。
・2シート目のある列に同じ値がある場合は、その行のある列の値を取得して、2シート目内のあるセルの文章の中のある値に代入したい
・1シート目のアクティブセルの行の複数の列の値を、2シート目のあるセルの文章の中のある値に代入したい
・メール作成画面、下書き作成画面を立ち上げたい

前提

Outlookでメールを自動で作成し、宛先や件名などをエクセルシートに書かれた値を入れこみたいです。
具体的な値を参照する方法は、エクセルの1枚目のシート「Sheet1」上である複数行に及ぶセルをクリックして選択している状態にします。
その選択されたアクティブセルそれぞれと同じ行のK列目のセルに入っている値と同じ値が、エクセル2枚目のシート「Sheet2」のM列のどこかの行にある場合に、「Sheet2」でその行のM列とN列とO列の値をそれぞれ、既に定義してある変数「Companyname」「Username」「mailaddress」に代入します。
「Sheet2」の「B6」セルにはメールの本文に書きたい文章が入っていて、 文章の中の{メーカー} {品目} {型番} {個数} {単位} {見積納期}という単語は、「Sheet1」上で選択されている複数行のセルの各行のF列、G列、H列、I列、J列、L列の値を入れたいです。作成したメールの表示、下書き保存まで行いたいです。

エラーは出ませんがOutlookの「プロファイルの選択」というダイアログボックスが出現して、OKを押すとボックスは消えてそのまま何も起こりません。いつも普通にOutlookを立ち上げるときはOKを押すとメールボックスが立ち上がるのですが。

VBA

'変数設定の指定
Option Explicit
 
Sub SendMail_HTML()
 
    'シート設定
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    
    Dim ws2 As Worksheet
    Set ws2 = Worksheets("Sheet2")
         
    'Outlookアプリケーションを起動
    Dim outlookObj As Outlook.Application
    Set outlookObj = New Outlook.Application
   
   
    'Outlookメールを作成
    Dim mymail As Outlook.MailItem
    
    '変数設定
    Dim cmax As Long
    Dim i As Long
    Dim Companyname As String
    Dim username As String
    Dim mailaddress As String
    Dim txt As TextStream
    Dim honbun As String
    Dim subject As String
    Dim mailbody As String
    Dim strstyle As String
    Dim maxrow As Integer
    Dim maker As String
    Dim item As String
    Dim model As String
    Dim number As String
    Dim unit As String
    Dim duedate As String
    
     'FileSystemObjectの設定
    Dim fs As Scripting.FileSystemObject
    Set fs = New Scripting.FileSystemObject
    '各シートの記載情報を取得
    cmax = ws1.Cells(Rows.Count, 1).End(xlUp).Row '最終行を取得
    If cmax = 1 Then Exit Sub 'データがなければ終了
    
    'メール作成
    For i = 2 To cmax '2行目から最終行まで処理を繰り返す
        maker = ws1.Cells(i, 6).Value '各列の値を取得
        item = ws1.Cells(i, 7).Value
        model = ws1.Cells(i, 8).Value
        number = ws1.Cells(i, 9).Value
        unit = ws1.Cells(i, 10).Value
        duedate = ws1.Cells(i, 12).Value
        
        'Sheet2で条件に一致する行を取得
        Dim foundRow As Range
        Set foundRow = ws2.Range("M:M").Find(What:=maker, LookAt:=xlWhole)
        
        If Not foundRow Is Nothing Then '条件に一致する行がある場合
            Set mymail = outlookObj.CreateItem(olMailItem)
            
            'プログラム12｜メール情報と本文を取得
            Companyname = ws2.Cells(foundRow.Row, 13).Value
            username = ws2.Cells(foundRow.Row, 14).Value
            mailaddress = ws2.Cells(foundRow.Row, 15).Value
            mymail.BodyFormat = 2        'HTMLに変更
            mymail.To = mailaddress
            mymail.CC = ws2.Range("B3").Value   'cc宛先
            mymail.BCC = ws2.Range("B4").Value  'bcc宛先
            mymail.subject = ws2.Range("B5").Value     '件名
            honbun = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(ws2.Range("B6").Value, "{会社}", Companyname), "{名前}", username), "{メーカー}", maker), "{品目}", item), "{型番}", model), "{個数}", number), "{単位}", unit), "{納期}", duedate), vbLf, "<br>")
            strstyle = "<font face=""游ゴシック (本文のフォント - 日本語)"" color=""&H000000"">" & honbun & "</font>"
            mailbody = strstyle
            
            
            'メール送信
            mymail.Display  'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない)
            mymail.Save    '下書き保存
            mymail.send    'メール送信
            
            'オブジェクト解放
            Set mymail = Nothing
        End If
    Next
    Set outlookObj = Nothing
 
'プログラム終了
End Sub

試したこと

ChatGPTで質問をして
下記のコードを追記したのですがprofileName:=の部分で「コンパイルエラー：名前付き引数が見つかりません」と出て何を入力すれば良いか分からず止まっています。
またこのコードを不特定多数の人間が使う予定なので私の個別の引数を入力しなければならないとすると困ります。
'Outlookのプロファイルを指定
Dim outlookNamespace As Outlook.Namespace
Set outlookNamespace = outlookObj.GetNamespace("MAPI")
outlookNamespace.Logon profileName:="プロファイル名", Password:="", ShowDialog:=False, NewSession:=False
。

追伸
下記の部分をコメントアウトするのと
'各シートの記載情報を取得
'cmax = ws1.Cells(Rows.Count, 1).End(xlUp).Row '最終行を取得
'If cmax = 1 Then Exit Sub 'データがなければ終了

Nextの位置をForの塊の下に持ってくると
'メール作成
For i = 2 To cmax '2行目から最終行まで処理を繰り返す
maker = ws1.Cells(i, 6).Value '各列の値を取得
item = ws1.Cells(i, 7).Value
model = ws1.Cells(i, 8).Value
number = ws1.Cells(i, 9).Value
unit = ws1.Cells(i, 10).Value
duedate = ws1.Cells(i, 12).Value
Next

「プロファイルの選択」からOKの後にメールが作成されるところまで行きました。
しかし本文や宛先には何も入っておらずアクティブなセルから取得したい値を取ることはできませんでした。

---

「mymail.HTMLBody = strstyle」にしてSheet1に項目追加でメール文面に値が反映される（値がまちがっているが）ときのコード

'変数設定の指定
Option Explicit

Sub SendMail_HTML()

'シート設定
Dim ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")

Dim ws2 As Worksheet
Set ws2 = Worksheets("Sheet2")
     
'Outlookアプリケーションを起動
Dim outlookObj As Outlook.Application
Set outlookObj = New Outlook.Application



'Outlookメールを作成
Dim mymail As Outlook.MailItem


'変数設定
Dim cmax As Long
Dim i As Long
Dim Companyname As String
Dim username As String
Dim mailaddress As String
Dim txt As TextStream
Dim honbun As String
Dim subject As String
Dim mailbody As String
Dim strstyle As String
Dim maxrow As Integer
Dim maker As String
Dim item As String
Dim model As String
Dim number As String
Dim unit As String
Dim duedate As String

 'FileSystemObjectの設定
Dim fs As Scripting.FileSystemObject
Set fs = New Scripting.FileSystemObject


'メール作成
maxrow = Selection.Row
maker = ws1.Cells(maxrow, 6).Value '各列の値を取得
item = ws1.Cells(maxrow, 7).Value
model = ws1.Cells(maxrow, 8).Value
number = ws1.Cells(maxrow, 9).Value
unit = ws1.Cells(maxrow, 10).Value
duedate = ws1.Cells(maxrow, 12).Value

'Sheet2で条件に一致する行を取得
Dim foundRow As Range
Set foundRow = ws2.Range("M:M").Find(What:=maker, LookAt:=xlWhole)
    
If Not foundRow Is Nothing Then '条件に一致する行がある場合
    Set mymail = outlookObj.CreateItem(olMailItem)
        
    'プログラム12｜メール情報と本文を取得
    Companyname = ws2.Cells(foundRow.Row, 13).Value
    username = ws2.Cells(foundRow.Row, 14).Value
    mailaddress = ws2.Cells(foundRow.Row, 15).Value
    mymail.BodyFormat = 2        'HTMLに変更
    mymail.To = mailaddress
    mymail.CC = ws2.Range("B3").Value   'cc宛先
    mymail.BCC = ws2.Range("B4").Value  'bcc宛先
    mymail.subject = ws2.Range("B5").Value     '件名
    honbun = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(ws2.Range("B6").Value, "{会社}", Companyname), "{名前}", username), "{メーカー}", maker), "{品目}", item), "{型番}", model), "{個数}", number), "{単位}", unit), "{納期}", duedate), vbLf, "<br>")
    strstyle = "<font face=""游ゴシック (本文のフォント - 日本語)"" color=""&H000000"">" & honbun & "</font>"
    mymail.HTMLBody = strstyle
        
    
    'メール送信
    mymail.Display  'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない)
    mymail.Save    '下書き保存
    'mymail.send    'メール送信
        
    
End If
'オブジェクト解放
Set mymail = Nothing
Set outlookObj = Nothing

'プログラム終了
End Sub

---

「mymail.HTMLBody = strstyle」にしたがSheet1に項目追加していなくてメール文面に値が反映されないときのコード（文字数制限のため違うところのみ記載）

'メール作成
For i = 2 To cmax '2行目から最終行まで処理を繰り返す
    maker = ws1.Cells(i, 6).Value '各列の値を取得
    item = ws1.Cells(i, 7).Value
    model = ws1.Cells(i, 8).Value
    number = ws1.Cells(i, 9).Value
    unit = ws1.Cells(i, 10).Value
    duedate = ws1.Cells(i, 12).Value
 Next
   

---

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[logres_Fan]

質問を下記のように変更できますか？
シート1のスクリーンショット、シート2のスクリーンショットの順番に表示。
シート1の余白(1から5行目)を削除。
シート2の会社、名前、メールアドレスの空欄を全て埋める。
シート2のcc宛先、bcc宛先を仮の値で埋める。
コードのhonbunをDebug.PrintやMsgBoxで展開した結果を併記。
> しかし本文や宛先には何も入っておらずアクティブなセルから取得したい値を取ることはできませんでした。
スクリーンショットの追加

[logres_Fan]

Excelを下記のように変更できますか？
>1シート目のアクティブセルの行のある列の値を2シート目のある列の中から探したい。
シート1の表に新しい項目を追加する。(メーカーの右隣に名前、メールアドレス)
新しい項目に数式を設定する。(シート2を探索して値を参照表示)
> 1シート目のアクティブセルの行の複数の列の値を、2シート目のあるセルの文章の中のある値に代入したい
シート1の表に新しい項目を追加する。(備考の右隣に本文)
新しい項目に数式を設定する。({メーカー} {品目} {型番} {個数} {単位} {見積納期}のセル参照値と文字列を結合して本文を作成)

[mizumizumizu]

logres_Fan様
コメント頂きありがとうございます。助かります。
返信が遅れて申し訳ありません。

頂いた2件のコメントに対する進捗を下記に記入しました。
画像添付はこのあと行わせて頂きます。

>>>下記実施、このあと画像載せさせて頂きます。
シート1のスクリーンショット、シート2のスクリーンショットの順番に表示。
シート1の余白(1から5行目)を削除。
シート2の会社、名前、メールアドレスの空欄を全て埋める。
シート2のcc宛先、bcc宛先を仮の値で埋める。
コードのhonbunをDebug.PrintやMsgBoxで展開した結果を併記。

>>>下記、新しく作った本文という項目の列のセルの中に元々書いていた文章を文字列として入れました。しかしその文字列の中の例えば｛メーカー｝という文字を消してF2セルの値を参照するのが上手くできませんでした。＆で囲ってみたのですが値になっていないように見えます。
それとテスト的に項目を増やすのは問題ないですが最終的なSheet1の構成は元々の構成にしたいです。（名前、メールアドレス、本文などは無い状態）
わがままを言って申し訳ありません。
>1シート目のアクティブセルの行のある列の値を2シート目のある列の中から探したい。
シート1の表に新しい項目を追加する。(メーカーの右隣に名前、メールアドレス)
新しい項目に数式を設定する。(シート2を探索して値を参照表示)
> 1シート目のアクティブセルの行の複数の列の値を、2シート目のあるセルの文章の中のある値に代入したい
シート1の表に新しい項目を追加する。(備考の右隣に本文)
新しい項目に数式を設定する。({メーカー} {品目} {型番} {個数} {単位} {見積納期}のセル参照値と文字列を結合して本文を作成)

[logres_Fan]

> ＆で囲ってみたのですが値になっていないように見えます。
セル参照部分をダブルクォテーションの外に出す、例えば、「=“&M2&G2様…」を「=M2&G2&”様…」のようにすると値になりますか？

[mizumizumizu]

ご返信ありがとうございます。
アドバイス頂いたやり方でやってみると画像5枚目のように「M2とG2」の部分は上手く反映されました。
同様にやろうと思って画像6のように日本語の部分は"　"で囲ってセルの値を参照するところは=をつけたのですが画像7枚目のようなエラーが出てしまいました。

[logres_Fan]

＝が不要です。(Excelにセルの中身が数式であると伝えるために、先頭の＝だけ残してみて下さい。)例えば、「”見積納期:”＝&N2&”」の部分は、「「”見積納期:”&N2&」
> 本文や宛先には何も入っておらずアクティブなセルから取得したい値を取ることはできませんでした。
コード中の「mymail.To = mailaddress」を「mymail.To = “hogehpge”」に変更すると改善しますか？
コード中の「mailbody = strstyle 」を「mymail.HTMLBody」に変更すると改善しますか？

[mizumizumizu]

ご返信ありがとうございます。

>>>下記部分は見積納期の「2023/3/21」の部分が「45006」と表示されてしまいました。セルの書式設定で日付に変えてみたのですが変化ありませんでした。他の項目は反映されました。
＝が不要です。(Excelにセルの中身が数式であると伝えるために、先頭の＝だけ残してみて下さい。)例えば、「”見積納期:”＝&N2&”」の部分は、「「”見積納期:”&N2&」

>>>.HTMLBodyの部分でコンパイルエラー：プロパティの使い方が不正です。と出ました。hogehpgeは当然変数定義して、すべてのmailaddressを置き換えないとダメですよね？
> 本文や宛先には何も入っておらずアクティブなセルから取得したい値を取ることはできませんでした。
コード中の「mymail.To = mailaddress」を「mymail.To = “hogehpge”」に変更すると改善しますか？
コード中の「mailbody = strstyle 」を「mymail.HTMLBody」に変更すると改善しますか？

[logres_Fan]

>.HTMLBodyの部分でコンパイルエラー：プロパティの使い方が不正です。と出ました。
失礼しました。「mailbody = strstyle 」 を「mymail.HTMLBody = strstyle」に変更すると、改善しますか？プロパティエラーが出る場合、すみません、すぐにはわからないです。
> hogehpgeは当然変数定義して、すべてのmailaddressを置き換えないとダメですよね？
その前に、まず、直接コードに打ち込んだ場合 、mymail.To = “ここに何か単語”、きちんとメール画面に出力されるか確認し、問題なければ、Debug.Print mailaddressが想定通りか確認する。如何でしょうか？

[mizumizumizu]

ご返信ありがとうございます。
mymail.HTMLBody = strstyleにして、mymail.To = mailaddressはそのままでやってみると
画像8枚目のようにメール作成できました。
Sheet1のM列の値は「c」に対して、Sheet2のM列が「b」の行が選ばれてしまいました。
ただメールに色々な項目が反映されているのはSheet1に「メーカー」「名前」「メールアドレス」「本文」を追加した効果なのでしょうか？
画像9枚目のように項目追加前のファイルでmymail.HTMLBody = strstyleに変更して実行すると
画像10枚目のように「宛先無し」「文面最初の会社名　名前なし」「本文は見積納期という文字列だけ」となりました。
試したことに、両方のコード追記します。

[mizumizumizu]

アドバイス頂いたSheet1に追加した「メーカー」「名前」「メールアドレス」「本文」の項目を消してもメール作成立ち上がりました。
Sheet1のK列は「c」なのにSheet2のM列は「b」の値の行が入ってきてしまっているところと
画像11のようにSheet1に2行目を書いて、2行目と3行目の両方がアクティブな状態で実行したのですが
2行目の方しかメールが立ち上がらないところが現状の問題のようです

[mizumizumizu]

画像11で2行目（担当者が田中)の行はその行のセルをアクティブ化して実行するとメールが立ち上がるのですが、3行目（担当者が菊地）の行はこの行のセルだけをアクティブ化してもメールが立ち上がりません。
4行目以降の空白のセルをクリックしてもメールが立ち上がるので、2行目だけ無効になっているようです。

[mizumizumizu]

'Sheet2で条件に一致する行を取得
Dim foundRow As Range
Set foundRow = ws2.Range("M:M").Find(What:=maker, LookAt:=xlWhole)
の部分のwhat:=makerがmakerではなくK列（11列目の見積依頼先）でなければならないので
新しくDim request As String、request = ws1.Cells(maxrow, 11).Valueと定義して

'Sheet2で条件に一致する行を取得
Dim foundRow As Range
Set foundRow = ws2.Range("M:M").Find(What:=request, LookAt:=xlWhole)
と変更したら正しい内容が反映されるようになりました。
3行目だけアクティブ化しても立ち上がるようになりました。
ただ2行目と3行目両方をアクティブ化して実行すると2行目のメールしか立ち上がりませんでした。

[mizumizumizu]

見積納期の部分が置き換えられていない問題もありました。
honbunという文字列の中に、duedateという日付型を入れられないのかと思いduedate2という変数を作ってFormat関数でduedateを文字列に変換したのですがダメでした。
debag.printしてもduedateもdudate2も両方2023/3/21となっているので変換できていないのでしょうか？

'変数設定
Dim cmax As Long
Dim i As Long
Dim Companyname As String
Dim username As String
Dim mailaddress As String
Dim txt As TextStream
Dim honbun As String
Dim subject As String
Dim mailbody As String
Dim strstyle As String
Dim maxrow As Integer
Dim maker As String
Dim item As String
Dim model As String
Dim number As String
Dim unit As String
Dim duedate As Date
Dim duedate2 As String

Dim request As String

'FileSystemObjectの設定
Dim fs As Scripting.FileSystemObject
Set fs = New Scripting.FileSystemObject

'メール作成
maxrow = Selection.Row
maker = ws1.Cells(maxrow, 6).Value '各列の値を取得
item = ws1.Cells(maxrow, 7).Value
model = ws1.Cells(maxrow, 8).Value
number = ws1.Cells(maxrow, 9).Value
unit = ws1.Cells(maxrow, 10).Value
duedate = ws1.Cells(maxrow, 12).Value
duedate2 = Format(duedate, "yyyy/mm/dd")

request = ws1.Cells(maxrow, 11).Value

Debug.Print duedate
Debug.Print duedate2

[logres_Fan]

　差し当たり、Excelのセル文字列「見積納期」に対して、コード「納期」になっていないかの確認して下さい。打ち間違いでなければ、ちょっとすぐにはわからない。
>2行目と3行目両方をアクティブ化して実行すると2行目のメールしか立ち上がりませんでした。
　アクティブ化というのは、表を範囲選択するという認識で合っていますかね。すみません、当初のようにループ処理で試行錯誤くらいしか直ぐには思い付かないです。そして、その場合、シート1の表に新しい項目と数式であれこれやっておくほうがたぶん見やすいかな。新しい項目をユーザに触って欲しくない場合、右端に寄せて非表示もしくはロックをかけるとかでしょうか。複雑なコードを取るか微妙な画面を取るかです。

[mizumizumizu]

logres_Fan様

ありがとうございます。
本当に助かります。

まさしくExcelのセル文字列「見積納期」に対して、コード「納期」になっていました。
解決しました。

アクティブ化の認識合っています。
Sheet1の2行目のみセル選択　→　メールは1通立ち上がる
2,3行目を選択　→　メールは2通立ち上がる
というのをやりたいです。

[logres_Fan]

回答を修正しましたので、ぼちぼち頑張って下さい。

Answer 1

既製品を導入するか、外注して下さい。
追記
メールが立ち上がらないのは、最終行が常に1、データがないので終了となっていたからでした。間に合わせですが、B列に変更すると改善します。

cmax = ws1.Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得
If cmax = 1 Then Exit Sub 'データがないので終了
cmax = ws1.Cells(Rows.Count, 2).End(xlUp).Row 'B列の最終行を取得
If cmax = 1 Then Exit Sub 'データがあれば終了しない

　メールは立ち上がるが、値が期待通りに反映されない。

• Findメソッドの引数に指定したかったのは、メーカーじゃなくて見積依頼先。解決済み。
• 本文空欄問題は、mymail.HTMLBodyを設定。mymail.HTMLBody = strstyle。解決済み。
• 打ち間違い問題は、{納期}を{見積納期}に。解決済み。
• Findメソッドのずれは、アルファベットの半角全角違いでも起きるので**要確認*。検索に使うセル文字が半角ならば検索対象も半角に揃えておく事。全角a-zA-Zを試す場合、半角a-zA-Zに自動変換される場合があるので工夫する事。
• 打ち間違い問題は、波型の括弧{}の半角全角違いでも起きるので要確認。セル文字列が半角中括弧ならばコード表記も半角中括弧に揃える事。

---

複合選択メール立ち上げ

For Each rng In Selection.Rows
　If rng.Row = 1 Then
　GoTo Continue
　End If

　i = rng.Row
　maker = ws1.Cells(i,6).Value
　…
　request = ws1.Cells(i,11).Value
　…
　〜
　…
　　End If
　Continue:
Next

その他

If cmax = 1 Then
　Exit Sub
End If

If Selection.Rows.Count > cmax Then
　Exit Sub
End If

打ち間違いがあるかもしれないので、参考程度に対応して下さい。

Comments

[mizumizumizu]

ご回答ありがとうございます。
既製品導入も外注も予算的に難しく自分で作りたいと思っています。
もし何かプログラム修正のアドバイス頂けたら大変助かります。