Outlookでの連絡先グループの管理はやめてExcelで管理する方法

1 Outlookのグループメンバを使用することで生じる弊害
2 ダウンロード
3 VBAマクロの説明
4 まとめ

Outlookのグループメンバを使用することで生じる弊害

Outlookで定期的に関係者（グループメンバ）へメール送信している場合、グループメンバの異動があるとメールアドレスの修正漏れにより正確に送信できないことがあります。それは、Outlookの連絡先グループの修正ミスや修正漏れにより発生します。特に複数の連絡先グループに関係している人が異動した場合がそうです。メールを送信してから異動した旨の返信をもらいはじめてそれに気が付き、グループのメンバ修正を行い、後任者へそのメールを送信します。

業務で定期的にメール送信している方は、いっそのことOutlookでの連絡先グループの管理をやめてExcelで管理した方が効率的です。Excelで管理すれば誰にどの案件のメールを送信しなければならないのか一覧表示で管理できる上に、案件毎の本文もまとめて管理できるので楽です。さらにマクロを使用してメールも送信することができるのです。

それでは、Excelで管理する方法を説明します。縦方向にメールアドレス、横方向に案件の表を一つのシートに作成します。案件列へは、宛先となる人は、’*’文字をCcとなる人は、’+’文字を設定します。Bccが必要であれば’-‘文字を設定します。異動によりメール送信が不要となったメンバの行を削除し、新たにメンバが増えた場合は、対象者の行を追加または挿入します。一時的に送信が不要となったメンバの行を非表示にすれば行を削除しなくても送信対象から外すことができます。

次にメール本文ですが、案件名のシートを作成し本文を記載します。メールの書式は、プレーンテキストとHTMLのどちらかを設定することができます。またファイルを添付することも可能で、ファイルの場所をフルパスで添付ファイルセルの下へ設定します。添付ファイルは行を挿入することで複数設定することができます。その際の注意として、本文セルの上のセルは空欄にしてください。本文は、本文セルの下から設定します。その際の注意として、文字の色、背景色、ハイパーリンク設定を行う場合は、それらを別のセルにします。

ダウンロード

メール管理.xlsm

VBAマクロの説明

例．月報提出依頼メールのフロー

Outlookのメールオブジェクトを作成します。
メールオブジェクトへ宛先とCcを設定します。
メールオブジェクトへ件名を設定します。
メールフォーマット（PLAINかHTML）を設定します。
案件に対応するタブからメール本文へコピペします。
メールフォーマットがHTMLの場合、表形式から”~”区切りへ変換します。
”~”区切りを削除します。

Sub 月報提出依頼メール()

    Call makeMail("月報提出", "HTML", "月報提出依頼")

1	Call makeMail("月報提出", "HTML", "月報提出依頼")

案件毎に作成するサブルーチンで、共通関数 makeMail をコールします。

引数１：案件名（「月報提出」）

引数２：メールのフォーマット（「HTML」）

引数３：メールの件名（「月報提出依頼」）

共通関数 makeMail(案件名、メールのフォーマット、メールの件名)

Private Function makeMail(item As String, form As String, title As String)
    Dim outlookObj As Object
    Dim mailItemObj As Object
    Set outlookObj = CreateObject("Outlook.Application")
    Set mailItemObj = outlookObj.CreateItem(olMailItem)
    Dim clm As Long
    Dim i As Long, j As Long
    Dim buf As String
    
    With Worksheets("MailAddress")
        For clm = 4 To .Cells(1, Columns.Count).End(xlToLeft).Column
            If .Cells(1, clm) = item Then Exit For
        Next
    End With
  
    With mailItemObj
        .To = getAddress(clm, "To")
        .CC = getAddress(clm, "Cc")
        Dim dtLm As String
        .Subject = title
        If form = "HTML" Then
            .BodyFormat = olFormatHTML
        Else
            .BodyFormat = olFormatPlain
        End If
        i = 2
        Do While Worksheets(item).Cells(i, 1) <> ""
            .Attachments.Add Trim(Worksheets(item).Cells(i, 1)) 'Trimは、必須
            i = i + 1
        Loop
        
        .Display
    End With
    
'   Outlookへ文字を送る
    Dim rowSt As Long, rowEd As Long, clmEd As Long
    Dim objdoc As Variant
    With Worksheets(item)
        rowSt = .Range("A:A").Find(What:="本文").Offset(1).Row
        rowEd = .Range("A" & Rows.Count).End(xlUp).Row
        Set objdoc = outlookObj.ActiveInspector.WordEditor
        For i = rowSt To rowEd
            clmEd = .Cells(i, Columns.Count).End(xlToLeft).Column
            If form = "HTML" Then
                .Range(.Cells(i, 1), .Cells(i, clmEd)).Copy 'セルの内容をクリップボードへコピー
                objdoc.Characters.last.Paste
            Else
                For j = 1 To clmEd
                    buf = .Cells(i, j)  'セルの内容を取り出す
                    If buf <> "" Then
                        objdoc.Application.Selection.TypeText buf
                    End If
                Next
                objdoc.Application.Selection.TypeText vbCrLf
            End If
        Next
    End With
    Application.CutCopyMode = True
    
    'Excel表形式から通常のフォームへ変換する
    If form = "HTML" Then
        BatchConvertAllTablesToText
        
        Call SetBackgroundColor(Worksheets(item))
    End If
End Function

Private Function makeMail(item As String, form As String, title As String)

Dim outlookObj As Object

Dim mailItemObj As Object

Set outlookObj = CreateObject("Outlook.Application")

Set mailItemObj = outlookObj.CreateItem(olMailItem)

Dim clm As Long

Dim i As Long, j As Long

Dim buf As String

With Worksheets("MailAddress")

For clm = 4 To .Cells(1, Columns.Count).End(xlToLeft).Column

If .Cells(1, clm) = item Then Exit For

End With

With mailItemObj

.To = getAddress(clm, "To")

.CC = getAddress(clm, "Cc")

Dim dtLm As String

.Subject = title

If form = "HTML" Then

.BodyFormat = olFormatHTML

Else

.BodyFormat = olFormatPlain

End If

i = 2

Do While Worksheets(item).Cells(i, 1) <> ""

.Attachments.Add Trim(Worksheets(item).Cells(i, 1)) 'Trimは、必須

i = i + 1

Loop

.Display

End With

' Outlookへ文字を送る

Dim rowSt As Long, rowEd As Long, clmEd As Long

Dim objdoc As Variant

With Worksheets(item)

rowSt = .Range("A:A").Find(What:="本文").Offset(1).Row

rowEd = .Range("A" & Rows.Count).End(xlUp).Row

Set objdoc = outlookObj.ActiveInspector.WordEditor

For i = rowSt To rowEd

clmEd = .Cells(i, Columns.Count).End(xlToLeft).Column

If form = "HTML" Then

.Range(.Cells(i, 1), .Cells(i, clmEd)).Copy 'セルの内容をクリップボードへコピー

objdoc.Characters.last.Paste

Else

For j = 1 To clmEd

buf = .Cells(i, j) 'セルの内容を取り出す

If buf <> "" Then

objdoc.Application.Selection.TypeText buf

End If

objdoc.Application.Selection.TypeText vbCrLf

End If

End With

Application.CutCopyMode = True

'Excel表形式から通常のフォームへ変換する

If form = "HTML" Then

BatchConvertAllTablesToText

Call SetBackgroundColor(Worksheets(item))

End If

End Function

指定された案件名から列番号を決定します。

列番号と宛先種別を引数に共通関数 getToAddress をコールすることで、メールの宛先とCcを受け取ります。受け取ったアドレスをメールオブジェクトへ設定します。

続けてメールのフォーマットとメールの件名をメールオブジェクトへ設定します。

案件名に対応するシートの添付ファイルのファイルパスをメールオブジェクトへ設定します。

案件名に対応するシートの本文をワードエディタオブジェクトへ設定します。

共通サブルーチン BatchConvertAllTablesToText をコールし通常のフォームへ変換します。

共通サブルーチン ReplaceNewLineTag をコールしタグを削除します。

共通関数 getAddress(列番号、宛先種別)

Private Function getAddress(clm As Long, tocc As String) As String
    Dim i As Long
    Dim i_Row As Long
    Dim toAddr As String
    Dim schar As String
    
    If tocc = "To" Then
        schar = "*"
    Else
        schar = "+"
    End If
    With Worksheets("MailAddress")
        i_Row = .Range("C1").CurrentRegion.Rows.Count
        For i = 2 To i_Row
            If .Cells(i, clm) = schar And .Cells(i, clm).EntireRow.Hidden = False Then
                toAddr = toAddr & ";" & .Cells(i, 3)
            End If
        Next
    End With
    getAddress = toAddr
End Function

Private Function getAddress(clm As Long, tocc As String) As String

Dim i As Long

Dim i_Row As Long

Dim toAddr As String

Dim schar As String

If tocc = "To" Then

schar = "*"

Else

schar = "+"

End If

With Worksheets("MailAddress")

i_Row = .Range("C1").CurrentRegion.Rows.Count

For i = 2 To i_Row

If .Cells(i, clm) = schar And .Cells(i, clm).EntireRow.Hidden = False Then

toAddr = toAddr & ";" & .Cells(i, 3)

End If

End With

getAddress = toAddr

End Function

MailAddressシートの列番号で指定された列から宛先種別に対応するメールアドレスを文字列にして返します。その際、非表示列のメールアドレスは含まれません。

共通サブルーチン BatchConvertAllTablesToText()

Private Sub BatchConvertAllTablesToText()
    Dim objMail As Outlook.MailItem
    Dim objMailDocument As Word.Document
    Dim objTables As Word.Tables
    Dim objTable As Word.Table
 
    'Get the currently opened email
    Set objMail = Outlook.Application.ActiveInspector.CurrentItem
    Set objMailDocument = objMail.GetInspector.WordEditor
 
    'Get all the tables of the current email
    Set objTables = objMailDocument.Tables
 
    'Convert all tables to text
    For Each objTable In objTables
        objTable.ConvertToText Separator:="~"
    Next
        
    'Delete separator
    With objMailDocument.Content.Find
          .ClearFormatting              '検索条件から書式を削除
          .Text = "~"                       'Separator
          .Replacement.ClearFormatting
          .Replacement.Text = ""   'Delete
          .Forward = True               '下方向に検索
          .Wrap = wdFindContinue '文書の末尾に到達した場合、検索を文書の先頭から続行
          .Format = False                '書式の置き換えをしない
          .MatchCase = True           '大文字と小文字を区別
          .MatchWholeWord = False             '完全に一致する単語
          .Execute Replace:=wdReplaceAll  '置換文字列を全て
    End With

End Sub

Private Sub BatchConvertAllTablesToText()

Dim objMail As Outlook.MailItem

Dim objMailDocument As Word.Document

Dim objTables As Word.Tables

Dim objTable As Word.Table

'Get the currently opened email

Set objMail = Outlook.Application.ActiveInspector.CurrentItem

Set objMailDocument = objMail.GetInspector.WordEditor

'Get all the tables of the current email

Set objTables = objMailDocument.Tables

'Convert all tables to text

For Each objTable In objTables

objTable.ConvertToText Separator:="~"

'Delete separator

With objMailDocument.Content.Find

.ClearFormatting '検索条件から書式を削除

.Text = "~" 'Separator

.Replacement.ClearFormatting

.Replacement.Text = "" 'Delete

.Forward = True '下方向に検索

.Wrap = wdFindContinue '文書の末尾に到達した場合、検索を文書の先頭から続行

.Format = False '書式の置き換えをしない

.MatchCase = True '大文字と小文字を区別

.MatchWholeWord = False '完全に一致する単語

.Execute Replace:=wdReplaceAll '置換文字列を全て

End With

End Sub

セルをコピペして表形式になっている本文を”~”区切りに変換します。

次に区切り文字”~”を削除します。

共通サブルーチン SetBackgroundColor(sh As Worksheet)

Private Sub SetBackgroundColor(sh As Worksheet)
    Dim listNo As Long, clmEd As Long
    Dim i As Long, j As Long, clindex As Long
    Dim moji As String
    
    With sh
        listNo = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To listNo
            clmEd = sh.Cells(i, Columns.Count).End(xlToLeft).Column
            For j = 1 To clmEd
                If .Cells(i, j).Interior.ColorIndex <> xlNone Then
                    moji = .Cells(i, j).Text
                    clindex = .Cells(i, j).Interior.ColorIndex
                    Call SetTextBackColor(moji, clindex)
                End If
            Next
        Next i
    End With

End Sub

Private Sub SetBackgroundColor(sh As Worksheet)

Dim listNo As Long, clmEd As Long

Dim i As Long, j As Long, clindex As Long

Dim moji As String

With sh

listNo = .Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To listNo

clmEd = sh.Cells(i, Columns.Count).End(xlToLeft).Column

For j = 1 To clmEd

If .Cells(i, j).Interior.ColorIndex <> xlNone Then

moji = .Cells(i, j).Text

clindex = .Cells(i, j).Interior.ColorIndex

Call SetTextBackColor(moji, clindex)

End If

Next i

End With

End Sub

案件名に対応するシートから背景色が設定されているセルの文字列とカラーインデックスを特定します。

文字列とカラーインデックスを引数に共通関数 SetTextBackColor をコールして、メール本文の文字列の背景色を設定します。

共通関数 SetTextBackColor(ByVal moji As String, ByVal clindex As Long)

Private Sub SetTextBackColor(ByVal moji As String, ByVal clindex As Long)
    Dim cclr As Long
    Dim colorTable As Variant

    colorTable = Array(wdBlack, wdWhite, wdRed, wdBrightGreen, wdBlue, wdYellow, wdPink, wdTurquoise, wdDarkRed, wdGreen, wdDarkBlue, wdDarkYellow, wdViolet, wdTeal, wdGray25, wdGray50)
    If UBound(colorTable) < clindex - 1 Then Exit Sub
    cclr = colorTable(clindex - 1)
    
    Dim outlookObj As Object
    Dim objdoc As Variant
    Set outlookObj = CreateObject("Outlook.Application")
    Set objdoc = outlookObj.ActiveInspector.WordEditor
    
    Application.ScreenUpdating = False
    With objdoc
        .Application.Options.DefaultHighlightColorIndex = cclr
    
        With .Content.Find
            .ClearFormatting
            .Text = moji
            With .Replacement
                .Text = ""
                .ClearFormatting
                .Highlight = True
            End With
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchWildcards = False
            .Execute Replace:=wdReplaceAll
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub SetTextBackColor(ByVal moji As String, ByVal clindex As Long)

Dim cclr As Long

Dim colorTable As Variant

colorTable = Array(wdBlack, wdWhite, wdRed, wdBrightGreen, wdBlue, wdYellow, wdPink, wdTurquoise, wdDarkRed, wdGreen, wdDarkBlue, wdDarkYellow, wdViolet, wdTeal, wdGray25, wdGray50)

If UBound(colorTable) < clindex - 1 Then Exit Sub

cclr = colorTable(clindex - 1)

Dim outlookObj As Object

Dim objdoc As Variant

Set outlookObj = CreateObject("Outlook.Application")

Set objdoc = outlookObj.ActiveInspector.WordEditor

Application.ScreenUpdating = False

With objdoc

.Application.Options.DefaultHighlightColorIndex = cclr

With .Content.Find

.ClearFormatting

.Text = moji

With .Replacement

.Text = ""

.ClearFormatting

.Highlight = True

End With

.Forward = True

.Wrap = wdFindContinue

.Format = True

.MatchWildcards = False

.Execute Replace:=wdReplaceAll

End With

Application.ScreenUpdating = True

End Sub

メール本文から指定された文字列を検索して指定された背景色に設定します。

注）メール本文中に指定された文字列が複数存在する場合、それら全の背景色が設定されます。背景色に指定できるのは、基本16色です。

まとめ

定期的にグループへ送信するメールのアドレスを、Outlookのグループでアドレス管理していると異動があった場合に、修正漏れとなりがちです。
Excelでグループアドレス管理すれば修正漏れが発生しにくくなります。
Excelのマクロを使用することでグループへメール送信することができます。

Outlookでの連絡先グループの管理はやめてExcelで管理する方法

Outlookのグループメンバを使用することで生じる弊害

ダウンロード

VBAマクロの説明

例．月報提出依頼メールのフロー

Sub 月報提出依頼メール()

共通関数 makeMail(案件名、メールのフォーマット、メールの件名)

共通関数 getAddress(列番号、宛先種別)

共通サブルーチン BatchConvertAllTablesToText()

共通サブルーチン SetBackgroundColor(sh As Worksheet)

共通関数 SetTextBackColor(ByVal moji As String, ByVal clindex As Long)

まとめ

コメントを残す

人気の投稿とページ

カテゴリー

ブログをメールで購読

Outlookのグループメンバを使用することで生じる弊害

ダウンロード

VBAマクロの説明

例．月報提出依頼メールのフロー

Sub 月報提出依頼メール()

共通関数 makeMail(案件名、メールのフォーマット、メールの件名)

共通関数 getAddress(列番号、宛先種別)

共通サブルーチン BatchConvertAllTablesToText()

共通サブルーチン SetBackgroundColor(sh As Worksheet)

共通関数 SetTextBackColor(ByVal moji As String, ByVal clindex As Long)

まとめ

コメントを残す

RECOMMENDこちらの記事も人気です。

わずかマウス１クリックでIEからExcelへのコピペが完了！これがコピペ…

エクセルとアウトルックを連携してメール作成と管理をする方法

Outlook 複数の受信メールに同じ内容の返信を簡単にする方法

行き先掲示板をWebブラウザーではなくoutlookから表示確認する方法

IEからExcelへのコピペ業務は、マクロを使用することで効率化と時短が…

Outlook2016の設定で失敗しないメールの振り分方法

エクセルのマクロを使ってメール送信するこの方法

Outlook2016の設定でWebの更新情報を受け取る方法

人気の投稿とページ

カテゴリー

ブログをメールで購読