特定フォーマットのメールの内容を Excel ファイルにエクスポートし、メールをサブフォルダーに移動するマクロ


コメントにて以下のご要望をいただきました。


いつも勉強させていただいております。
  過去記事を参考にさせていただきマクロ作成を試しているのですが、
VBAについて理解が浅いためかうまく作成することができず、
お力をお貸しいただけないでしょうか。

■利用環境
OSバージョン:Windows7 SP1 & Windows10 RD2
  Outlookバージョン:Outlook2010

■参考にした過去記事
・メールの内容を Excel ファイルにかき出すマクロ
  ・本文から取得したデータを項目別に Excel のシートに書き出すマクロ
  ・決まった件名で終わるメッセージを受信したら、キーワードを含む 1 行を CSV ファイルに保存するマクロ
  ・Outlook 起動時に受信後 14 日が経過しているメールを受信トレイから移動するマクロ

■前提
  顧客のデータベースの内容が変更されると、翌日にシステムからメールが送られてきます。
  会社名や管理番号以外は変更があった箇所のみ以下のメール本文例のように記載されます。
  ([項目名]は固定値で変更がない場合はメールには記載されない。)

該当の[項目名]の後ろ何文字~何文字をエクセルに転記という形を目指してみましたが、
  間に「改行コード、半角スペース、任意の文字列(メールによって文字数は変動)」が
記載された行が含まれる事が要因かと思うのですが、全角と半角カナ英数字のときで
取得される位置が変わってしまい、よくわからなくなってしまいました。

◎実現したいこと
(1)指定フォルダ内のすべてのメールの本文内の特定の内容をエクセルに書き出したい。
   ※特定の内容は「変更後:」以降の文字列。(下記メール本文例を参照)
   「変更前:~(任意の文字列)」の行は転記はせずに飛ばしたい。
   ※メール本文内の[項目名]の前には半角スペース4つ、[変更前:][変更後:]の前には
   半角スペースが6つ記載されています。

(2)上記の処理がすべて完了後に該当フォルダのサブフォルダへ移動させたい。

●メール本文例1(※書き出し先のエクセル表のイメージの行4のように転記したい)
============================================================
会社名 :■■■ 株式会社 
  管理番号 :0000000003

変更点 :
2019/01/15
郵便番号
変更前:444-5555
変更後:333-3333

住所
変更前:■■県■■市4-5 ■■ビル5F
変更後:■■県■■市3-3-3 ■■ビル3F

============================================================

●メール本文例2(※書き出し先のエクセル表のイメージの行5のように転記したい)
============================================================
会社名 :○○○ 相互会社 
  管理番号 :0000000004

変更点 :
2019/01/15
部署名
変更前:第一製造部 
変更後:第三製造部 

部署名カナ
変更前:ダイイチセイゾウブ
変更後:ダイサンセイゾウブ

============================================================

◎書き出し先のエクセル表のイメージ

\A列 \B列 \C列 \D列 \E列 \F列 \
行1\①会社名 \②管理番号 \③部署名 \④部署名カナ \⑤郵便番号 \⑥住所 \
行2\●●● 株式会社 \0000000001 \管理本部 \カンリホンブ \111-1111 \●●市●●町1-1 ●●ビル4階 \
行3\□□□ 有限会社 \0000000002 \第一営業部 \ダイイチエイギョウブ \222-2222 \□□郡□□2-2-2 □□ビル2F \
行4\■■■ 株式会社 \0000000003 \ \ \333-3333 \■■市3-3-3 ■■ ビル3F \
行5\○○○ 相互会社 \0000000004 \第三製造部 \ダイサンセイゾウブ \ \ \

※各項目内の文字列についての補足(※具体例は書き出し先のエクセル表のイメージの行2、行3)
①会社名:全角
②管理番号:半角英数字
③部署名:全角
④部署名カナ:半角カナ
⑤郵便番号:半角英数字
⑥住所:全角、半角カナ英数字が混在 ※

※書き出し先のエクセル表のイメージ行1の項目は一例で、実際にはさらに数が多くなります。

お手数おかけして大変申し訳ございませんが、
  何卒よろしくお願いいたします。


このような処理は、メール本文をそのまま処理するより、改行で分割して 1 行ごとに処理するほうが良いでしょう。
VBA の Split 関数を使用して改行コード (vbLf) により本文を分割することで、配列に 1 行ごとの文字列が格納されます。
また、”:” より後ろのデータの取得についても Split 関数が使用できます。
そして、1 行ごとに以下のような処理をします。

  • “会社名 :” で始まる行は”:”より後ろを A 列に設定
  • “管理番号 :” で始まる行は”:”より後ろを B 列に設定
  • 項目名のみの行は対応する列番号のみを設定
  • “変更前:” で始まる行は無視
  • “会社名 :” で始まる行は”:” より後ろを列番号で指定された列に設定

上記の処理を行がなくなるまで繰り返し、処理が終わったらアイテムをサブフォルダーに移動します。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ExportModificationAndMove()
    ' エクスポートする Excel ファイル名
    Const EXCEL_FILE = "c:\temp\変更情報.xlsx"
    ' 処理が終わったアイテムを移動するサブフォルダー名
    Const SUBFOLDER_NAME = "処理済"
    Const VALUE_DELIMITER = ":"
    Dim objBook As Object 'Excel.Workbook
    Dim objSheet As Object 'Excel.Worksheet
    Dim iRow As Integer
    Dim iCol As Integer
    Dim fldCurrent As Folder
    Dim fldSub As Folder
    Dim i As Integer
    Dim objItem As MailItem
    Dim arrFields As Variant
    Dim arrLines As Variant
    Dim strLine As Variant
    Dim varPair As Variant
    ' 項目名を配列で指定
    arrFields = Array("部署名", "部署名カナ", "郵便番号", "住所")
    ' Excel ファイルを取得
    Set objBook = GetObject(EXCEL_FILE)
    objBook.Windows(1).Activate
    Set objSheet = objBook.Worksheets(1)
    ' データが入っていない行を検索
    iRow = 1
    While objSheet.Cells(iRow, 1) <> ""
        iRow = iRow + 1
    Wend
    ' 現在選択中のフォルダーを取得
    Set fldCurrent = ActiveExplorer.CurrentFolder
    ' サブフォルダーを取得
    Set fldSub = fldCurrent.Folders(SUBFOLDER_NAME)
    ' フォルダー内のすべてのアイテムを処理
    For i = fldCurrent.Items.Count To 1 Step -1
        Set objItem = fldCurrent.Items(i)
        ' 本文を行に分割する
        arrLines = Split(Replace(objItem.Body, vbCrLf, vbLf), vbLf)
        ' 行ごとに処理
        For Each strLine In arrLines
            ' 先頭の余分なスペースを削除
            strLine = Trim(strLine)
            ' :の前後の文字列を分ける
            varPair = Split(strLine, VALUE_DELIMITER)
            If strLine Like "会社名 :*" Then
                ' 会社名なら 1 列目に設定
                objSheet.Cells(iRow, 1) = varPair(1)
            ElseIf strLine Like "管理番号 :*" Then
                ' 管理番号なら 2 列目に設定
                objSheet.Cells(iRow, 2) = "'" & varPair(1)
            ElseIf strLine Like "変更後:*" Then
                ' 変更後なら下記で見つかった列に設定
                objSheet.Cells(iRow, iCol + 3) = varPair(1)
            ElseIf strLine Like "変更前:*" Then
                ' 変更前なら何もしない
            Else
                ' 項目名と一致するか検索
                For iCol = LBound(arrFields) To UBound(arrFields)
                    If strLine = arrFields(iCol) Then
                        ' 項目名が一致したら検索終了
                        Exit For
                    End If
                Next
            End If
        Next
        ' 処理済のアイテムをサブフォルダーに移動
        objItem.Move fldSub
        ' 次の行に移動
        iRow = iRow + 1
    Next
    objBook.Close True
End Sub

マクロの登録方法やメニューへの追加について

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中