VBAマクロを駆使して連絡先をOutlookに取り込む（第2回 マクロで自動処理）
前回は、準備としてダミーの個人情報データの用意や、Outlookに連絡先をインポートする方法について記載しました。
今回は、マクロでデータを切り分けつつ、さらにOutlookの連絡先に取り込みを行う方法を記載します。
なお、連絡先にそのまま入れるより、連絡先グループに取り込んだ方がその後の使い勝手はいいと思います。
1．実現する内容
以下の方法で実装したいと思います。
1. 連絡先に会社＋基準日でフォルダを作成
2. 連絡先グループにも同様に会社＋基準日でフォルダ作成
※ 1.2の切り分けが正しいか確認するために、会社・役割ごとのCSVファイルも作成。
2．VBAマクロの基本
そもそもマクロって、どこにコード書けばいいの？とかどうやって実行すればいいの？という方は以下の記事をまずはざっとお読みください。
3.処理の流れを考える
1.で記載したシステム要件を実現する処理の流れを考えます。
a. まずはエクセルの余分な箇所を削る
b. 列の並びがバラバラな場合は、一定のルールで並び替える
c. 担当ごとに配列を作成し、該当の担当が存在する行数を格納する
d. 担当ごとにCSVファイルを作成、該当行を貼り付ける
e. Outlookの連絡先に担当＋基準日名のフォルダを作成する
f. Outlookに担当＋基準日名の連絡先グループを作成する
g. 連絡先に担当者を登録し、連絡先に作成したフォルダに移動
h. 連絡先グループにも登録を行う
ざっとこんな流れで処理をするとします。
（やり方は色々あると思うので、自分なりのやり方を考えるのも、とても勉強になると思います！）
4.エクセルの余分な箇所を削る（a.部分）
エクセルのA1セルから、表が始まっていれば良いですが、得てして会社ごとにバラバラだったり、作成する人間によって余分あ行や列があったりするものです。（本当は統一してくれれば、済む話なのですが）
流れとしては表の最終行・最終列を特定し、そこから表の開始行・開始列を特定します。
表の範囲が分かることで、余分な行と列が分かるという攻め方です。
Sub 連絡先取り込み（）
’変数の定義
Dim wb As Workbook
Dim startRow As Long
Dim endRow As Long
Dim startCol As Long
Dim endCol As Long
'現在のWorkbookをWorkbookオブジェクトとして、変数wbに格納
set wb = ThisWorkbook
'最終行と最終列をそれぞれ変数に格納
endRow = wb.ActiveSheet.UsedRange.End(xlDown).Row
endCol = wb.ActiveSheet.UsedRange.End(xlToRight).Column
’取得した最終列から開始行を取得（そもそも最終列の１行目に値があれば１行目を開始列とする）
If Cells(1, endCol).Value = "" Then
startRow = Cells(1, endCol).End(xlDown).Row
Else
startRow = 1
'取得した開始行と最終列から開始列を取得(同様にそもそも１列目が空白でなければ１列目が開始列）
If Cells(endRow, 1).Value = "" Then
startCol = Cells(startRow, endCol).End(xlToLeft).Column
Else
startCol = 1
'冒頭にある余分な行と列を削除する
While startRow > 1
startRow = startRow - 1
Rows(startRow).Delete
Wend
While startCol > 1
startCol = startCol - 1
Columns(startCol).Delete
Wendここまでが、余分な行と列を削除するコードです。
RangeオブジェクトのUsedRangeメソッドを使って、表の最終行(End(xlDown).Row)と最終列(End(xlToLeft).Column)を特定します。
表の最終行・最終列が分かれば、最終列の1行目から入力のある行まで下がる（Cells(1, endCol).End(xlDown).Row)ことで、開始行が分かります。
同様に、最終列の最終行から、入力がある最後の列まで左に移動する
（Cells(endRow, endCol).End(xlToLeft).Column)ことで、開始列も分かります。
仕事で使うようなマクロだと、大体初っ端データ入力範囲を特定してから、処理を行うプログラムになることが経験上多いと思うので、覚えておいて損はないかと思います。
5.列の並びがバラバラな場合に一定のルールで並び替える(b.部分)
こちらも、フォーマットが会社ごとにバラバラだった場合の対策です。
（これもきちんと揃えてくれれば済む話ですが・・・）
処理の流れとしては、まずファイル内の項目の並びを確認し、ルールと照らして異なっていれば列単位でコピー・挿入をして整えるだけです。
（氏名→氏名（カタカナ）→電話番号→携帯電話番号→メールアドレス→会社名→PM→PMO→APL→移行→テスト）
なお、前述部分で定義した変数等は定義されてる前提で記載していきます。
（一番最後にコード全文は別途掲載してあります）
Dim companyColumn As Integer
Dim nameColumn As Integer
Dim nameKanaColumn As Integer
Dim telephoneColumn As Integer
Dim cellphoneColumn As Integer
Dim mailAddressColumn As Integer
Dim pmoCol As Integer
Dim aplCol As Integer
dim ikoCol As Integer
Dim testCol As Integer
’連絡先リストの各項目の列を取得していく
wb.Activate
companyColumn = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("会社名").Column
nameColumn = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("氏名").Column
nameKanaColumn = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("氏名(カタカナ)").Column
telephoneColumn = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("電話番号").Column
cellphoneColumn = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("携帯電話番号").Column
MailAddressColumn = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("メールアドレス").Column
pmoCol = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("PMO").Column
aplCol = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("APL").Column
ikoCol = Range(Cells(startRow, startCol), Cells(startRow, endCol)).Find("移行").Column
testCol = Rage(Cells(startRow, startCol), Cells(startRow, endCol)).Find("テスト").Column
’連絡先リストの並びを確認して、ルールとずれている場合は並び替えていく
'氏名
If nameColumn <> 1 Then
Columns(nameColumn).Cut
Columns(1).Insert
End If
’氏名カタカナ
If nameKanaColumn <> 2 Then
Columns(nameKanaColumn).Cut
Columns(2).Insert
End If
'電話番号
If telephoneColumn <> 3 Then
Columns(telephoneColumn).Cut
Columns(3).Insert
End If
・・・（中略）
'テスト
if testCol <> 11 Then
Columns(testCol).Cut
Columns(11).Insert
End If
項目ごとにあるべき列にいるかを、取得した列数で確認し、そうでなければ該当列を切り取って、本来の列に挿入しています。
6. 担当ごとに配列を作成し、該当の担当が存在する行数を格納する(c.部分)
では、次に担当が存在する行数を配列に格納していく処理について記載します。
配列とは、複数のデータを格納するデータ型でリストのような言い方をしたりします。（Pythonでいうとリスト型）
なお、僕はPythonから入ったのでですが、感覚的にはVBAの配列はやや面倒です。
まず配列の要素数（何個値を格納するか）は、担当により異なるのであらかじめ定義することはできません。
そこで動的な配列を定義して、格納していきます。
'ループ変数
Dim i As Long
'PMO担当メンバーを格納する配列を定義
Dim n1 As Integer
Dim pmoCols() As Integer
ReDim pmoCols(n1)
'APL担当メンバーを格納する配列を定義
Dim n2 As Integer
Dim aplCols() As Integer
ReDim aplCols(n2)
'移行担当メンバーを格納する配列を定義
Dim n3 As Integer
Dim ikoCols() As Integer
ReDim ikoCols(n3)
'テスト担当メンバーを格納する配列を定義
Dim n4 As Integer
Dim testCols() As Integer
ReDim testCols(n4)
'各担当の行を配列に格納していく
'PMOメンバーの行をpmoCols（配列）に格納していく
For i = startRow To endRow
If Cells(i, pmoCol).Value = "○" or Cells(i, pmoCols).Value = "◎" then
If Ubound(pmoCols) = 0 then
pmoCols(0) = i
n1 = n1 + 1
Redim Preserve pmoCols(Ubound(pmoCols) + 1)
Else
Redim Preserve pmoCols(Ubound(pmoCols) + 1)
n1 = n1 + 1
Redim Preserve pmoCols(Ubound(pmoCols) + 1)
End If
End If
Next
Redim Preserve pmoCols(n1 - 1)
'APLメンバーの行をaplCols（配列）に格納していく
For i = startRow To endRow
If Cells(i, aplCol).Value = "○" or Cells(i, aplCols).Value = "◎" then
If Ubound(aplCols) = 0 then
aplCols(0) = i
n1 = n1 + 1
Redim Preserve aplCols(Ubound(aplCols) + 1)
Else
Redim Preserve aplCols(Ubound(aplCols) + 1)
n1 = n1 + 1
Redim Preserve aplCols(Ubound(aplCols) + 1)
End If
End If
Next
Redim Preserve aplCols(n1 - 1)
'移行メンバーの行をikoCols（配列）に格納していく
For i = startRow To endRow
If Cells(i, ikoCol).Value = "○" or Cells(i, ikoCols).Value = "◎" then
If Ubound(ikoCols) = 0 then
ikoCols(0) = i
n1 = n1 + 1
Redim Preserve ikoCols(Ubound(ikoCols) + 1)
Else
Redim Preserve ikoCols(Ubound(ikoCols) + 1)
n1 = n1 + 1
Redim Preserve ikoCols(Ubound(ikoCols) + 1)
End If
End If
Next
Redim Preserve ikoCols(n1 - 1)
'テストメンバーの行をikoCols（配列）に格納していく
For i = startRow To endRow
If Cells(i, testCol).Value = "○" or Cells(i, testCols).Value = "◎" then
If Ubound(testCols) = 0 then
testCols(0) = i
n1 = n1 + 1
Redim Preserve testCols(Ubound(testCols) + 1)
Else
Redim Preserve testCols(Ubound(testCols) + 1)
n1 = n1 + 1
Redim Preserve testCols(Ubound(testCols) + 1)
End If
End If
Next
Redim Preserve testCols(n1 - 1)
これで、各担当の行が配列に格納されるので、後で何行目のデータを抽出すればいいかがコントロールできるようになりました。
7．担当ごとにCSVファイルを作成、該当行を貼り付ける（d. 部分）
タイトルなっが・・・笑
ここまでで、表を整えて捉えるべき担当の行も押さえたので、あとはCSVファイル、Outlookの連絡先、Outlookの連絡先グループと一気にアウトプットしていきます。
コードは基本的に同じものを、各担当分書きますのでPMO分のみここでは書きます。
'会社名を格納する変数
Dim Company As String
'ファイル作成にあたり、新しいブックのファイルパスやファイル名を格納する変数
Dim nwb As Workbook
Dim newBookName As String
Dim nbLastRow As Integer
Dim nbLastCol As Integer
Dim newRow As Integer
'連絡先リストの基準日を格納する変数
Dim referenceDate As String
'会社名を取得する
Company = Cells(startRow + 1, companyColumn).Value
'PMOファイルを作成し、ヘッダー行とPMOメンバー行を貼り付ける
newBookName = Company & "_PMO_" & referenceDate & ".csv"
newBookPath = ThisWorkbook.Path & "\更新リスト\" & newBookName
If Dir(newBookPath) = "" Then
Set nwb = Workbooks.Add
nwb.SaveAs Filename:=newBookPath, FileFormat:=xlCSV
Else
MsgBox "既にファイルがあります"
End if
wb.Active
'ヘッダー行をコピーして、新しいファイルに貼り付けする
wb.Worksheets(1).Range(Cells(starRow, startCol), Cells(startRow, endCol)).Copy
Set nwb = Workbooks.Open(newBookPath)
nwb.Worksheets(1).Cells(1, 1).Select
ActiveSheet.Paste
'２行目移行（データ部分）をコピーしながら、新しいファイルに貼り付ける
newRow = 2
For i = LBound(pmoCols) To UBound(pmoCols)
wb.Active
wb.Worksheets(1).Range(Cells(pnoCols(i), startCol), Cells(pmoCols(i), endCol)).Copy
nwb.Active
nwb.Worksheets(1).Cells(newRow, 1).Select
ActiveSheet.Paste
newRow = newRow + 1
Next
では、いよいよ次からOutlookへの取り込みです！
8.Outlookの連絡先にフォルダを作成する（e. 部分）・Outlookに連絡先グループを作成する（f. 部分）・連絡先への担当者登録・フォルダ移動（g. 部分）・連絡先グループに登録（h. 部分）
'Outlookのオブジェクトを格納する変数
Dim objOutlook As Outlook.Application
Dim of As Folder
Dim objContact As Outlook.ContactItem
Dim oContact As Outlook.Folder
Dim newFoldername As String
Dim olItems As Outlook.Items
Dim oDl As Outlook.DistListItem
Dim member As Recipient
'ここからOutlookへの取り込み処理
'列を挿入し、姓名を分割する
Columns(2).Insert
Columns(4).Insert
nbLastRow = Cells(rows.Count, 1).End(xlUp).Row
nbLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Application.DisplayAlerts = False '確認メッセージを非表示にする
Range(Cells(2, 1), Cells(nbLastRow, 1)).TextToColumns Space:=True
Range(Cells(2, 3), Cells(nbLastRow, 3)).TextToColumns Space:=True
'連絡先リストの各項目の列数を改めて格納
lastNameColumn = 1
firstNameColumn = 2
lastNameKanaColumn = 3
firstNameKanaColumn = 4
telephoneColumn = 5
cellphoneColumn = 6
companyColumn = 7
mailAddress = 8
'Outlookの連絡先に新規フォルダを作成し、登録する
newFolderName = Company & "_PMO_" & referenceDate
’Outlookオブジェクトをセット
Set objOutlook = New Outlook.Application
’連絡先のフォルダオブジェクトをセット（記載を省略するため）
Set oConatct = objOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'連絡先フォルダを追加
oContact.Folders.Add newFolderName
'連絡先リストオブジェクトをセット
Set oDl = Ocontact.Items.Add(oDlDistributionListItem)
oDl.DlName = newForlderName
’一旦保存
oDl.save
'ループ処理で連絡先を登録していく
For i = 2 To nbLastRow
Set objContact = objOutlook.CreatItem(olContactItem)
With objContact
.FirstName = Cells(i, firstNameColumn)
.LastName = Cells(i, lastNameColumn)
.Email1Address = Cells(i, mailAddress)
.Email1DisplayName = Comapny & Cells(i, LastNameColumn)
.CompanyName = Company
.CompanyTelephoneNumber = Cells(i, telephoneColumn)
.Business2TelephoneNumber = Cells(i, cellphoneColumn)
.YomiFirstName = Cells(i, firstNameKanaColumn)
.YomiLastName = Cells(i, lastNameKanaColumn)
.Save
End With
Set member = objOutlook.Session.CreateRecipient(Cells(i, lastNameColumn) & " " & Cells(i, firstNameColumn))
member.Resolve
oDl.AddMember member
oDl.Save
Set of = oContact.Folders.GetLast '最後尾に追加した新しいフォルダを取得
objContact.Move of '作成した連絡先フォルダに移動
Next
nwb.save
nwb.Closeまず、OutlookをVBAで触るにはエクセルのVBE（ビジュアルベーシックエディタ、つまりマクロのコードを書く画面）の「ツール」＞「参照設定」で、「MicroSoft Outlook XX.X（バージョン） Object Library」にチェックを入レます。
これにより、Outlookのオブジェクト操作が可能となります。詳しく知りたい方は以下サイトを参照ください。
ざっくりとポイントを解説すると、まずアウトルックオブジェクトを定義します。具体的には変数を用意して、そこにアウトルックオブジェクトを格納する。(以下2行でそれをやっています）
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application今度はアウトルックオブジェクトの名前空間から、連絡先情報を取得してoContactという変数に格納。
連絡先情報にフォルダを追加したり、連絡先リストを追加したりしています。
Dim of As Folder
Dim oContact As Outlook.Folder
Dim oDl As Outlook.DistListItem
Set oContact = objOutlook.GetNameSpace("MAPI").GetDefaultFolder(olFolderContacts)
oContact.Folders.Add newFolderName
Set of = oContact.Folders.GetLast
oDl.DlName = newFolderName
oDl.Saveofがフォルダーを格納する変数
oContactはいちいちobjOutlook.GetNameSpace("MAPI").GetDefaultFolder(olFolderContacts)という記載をするの省略するため、変数に格納してしまうもの。
oDlは連絡先リストを格納する変数という感じです。
あとは、Outlookの連絡先への実際の連絡先情報（氏名やカナ氏名、メールアドレスなど）の取り込みですが、こちらはobjContactというオブジェクトを定義して、Outlookの連絡先情報が持つ項目にCSVファイルの各項目をセットして保存している感じです。
中身がつまったら、先ほど用意した連絡先グループにメンバーとして登録しつつ、フォルダも追加したフォルダに移動する・・・という流れです。
9.留意事項
仕様上、エクセルのVBAからOutlookを操作して、連絡先情報を追加したりすること自体は可能なのですが、例えば会社の環境だとOutlook外部からの操作をブロックするような仕様になっていたりすることもあるかと思います。
セキュリティを考えたら、真っ当な対応だと思いますが、それによりできることが限られる可能性があることはご留意ください。
ちなみに、自宅の環境だと、このあと掲載しているコード全文で問題なく稼働しましたが、会社の環境だと連絡先へのフォルダ追加・連絡先グループ追加自体は可能なものの、そこに連絡先を追加することはNGでした。
なので、やむをえずCSVファイルをインポートして対応してます。
では、最後にコード全文を掲載しますので、良かったら私のモチベーションアップのためにも購入していただけると幸いです。
(ただ、頑張って公式ドキュメント読みながら、色々調べれば自分でもできるはずです。あくまでその手間をショートカットする目的での購入という位置付けになると思います。僕は大体3日くらいでできました。）
また、コードについては動くものの冗長な箇所等あるかと思います。
色々とご自分でカスタマイズされるのも、より身になる勉強となると思いますので、ぜひチャレンジしてみてください！
10.コード全文
コード全文は以下の通りです！
なお、当然OutlookがPCに存在すること、またOutlookを開いた状態でコードを実行する必要がありますので、その点だけお願いします！
ここから先は
¥ 500
この記事が気に入ったらサポートをしてみませんか？