予定表の件名を Excel にコピーするマクロ


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


初めまして

簡単なWebアプリケーションの開発の経験はありますが、VBAはよくわかりません。
#本屋で書籍を探しましたが、Outlook用VBAの本はありませんでした。
下記のような機能のマクロを作りたいのですが、教えて頂けないでしょうか?

1.”予定表”で、登録されている”予定”をクリックして選択。
  2.リボンに配置されたボタンをクリック。
  3.Excelが起動して、”予定”の”件名”に登録されていた文字列の中から()で
囲まれた文字列を、あらかじめ用意されたExcelファイルの特定セルに挿入する。

出来れば、同一日に”件名”に()が含まれた”予定”が複数存在する場合は、
”予定”毎に複数行に”件名”を挿入できるような機能があると嬉しいのですが。

例えば、
9/24の予定に下記の3件の予定が入っていた場合
=================================
【A会社】打合せ
【B会社】工事立会い
【C会社】現地調査
=================================

何らかの操作(マクロを登録されたボタンを押下?)をすることで、
Excelのテンプレートファイルを読み込んで、Outlookの予定の情報を
元に、A2:B4に情報を書込み、下記のようなExcelファイルが出来る
ようなマクロが希望です。

=================================
A B C
1 日付 お客様名
2 9/24 A会社
3 9/24 B会社
4 9/24 C会社
=================================


最初のご要望では予定表で選択した一つの予定について Excel にかき出すというようなものでしたが、例を見ると 1 日分の予定をまとめてコピーしたほうが良いのではないかと思います。
そのため、以下のようなマクロにしてみました。
このマクロ (CopyToExcel) を実行すると、現在開いている予定表で表示されている日の予定のうち件名に 【】 が含まれているものを Excel ファイルにコピーします。
Excel ファイルは EXCEL_TEMPLATE で指定したテンプレートファイルから新規作成します。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CopyToExcel()
    Const EXCEL_TEMPLATE = "c:\temp\template.xltx"
    Dim varArray As Variant
    Dim strDate 'As String
    Dim appExcel 'As Excel.Application
    Dim objBook 'As Excel.Workbook
    Dim iRow As Integer
    ' 日週月のビューでなければ終了
    If ActiveExplorer.CurrentView.ViewType <> olCalendarView Then
        Exit Sub
    End If
    ' Excel テンプレートから新規ファイル作成
    Set appExcel = CreateObject("Excel.Application")
    Set objBook = appExcel.Workbooks.Add(EXCEL_TEMPLATE)
    ' 2 行目からコピー開始
    iRow = 2
    ' 現在表示されている日付を取得
    varArray = ActiveExplorer.CurrentView.DisplayedDates
    If IsArray(varArray) Then
        ' 日付ごとにコピー処理
        For Each strDate In varArray
            CopyToExcelForADay strDate, objBook.Sheets(1), iRow
        Next
    End If
    appExcel.Visible = True
    appExcel.Windows(1).Visible = True
End Sub
' 1 日分のコピーを行うサブプロシージャ
Private Sub CopyToExcelForADay(ByVal strDate As String, objSheet As Variant, iRow As Integer)
    Dim strEnd As String
    Dim colItems As Items
    Dim apptItem As AppointmentItem
    strEnd = DateAdd("d", 1, CDate(strDate))
    Set colItems = ActiveExplorer.CurrentFolder.Items
    ' 指定された日付で開始される予定を検索
    colItems.Sort "[Start]"
    colItems.IncludeRecurrences = True
    Set apptItem = colItems.Find("[Start] >= """ & strDate & _
    " 0:00"" and [Start] < """ & strEnd & " 0:00""")
    ' 一致する予定がなくなるまで繰り返す
    While Not apptItem Is Nothing
        ' 一つの予定をコピー
        CopyOneAppointment apptItem, objSheet, iRow
        ' 次の予定を検索
        Set apptItem = colItems.FindNext
    Wend
End Sub
'
Private Sub CopyOneAppointment(apptItem As AppointmentItem, objSheet As Variant, iRow As Integer)
    Dim strText As String
    With apptItem
        ' 件名に【】がある場合だけ処理
        If .Subject Like "【*】*" Then
            ' 【】の中の文字を取り出す
            strText = Mid(.Subject, 2, InStr(.Subject, "】") - 2)
            ' 1 列目に日付
            objSheet.Cells(iRow, 1).Value = strDate
            ' 2 列目に【】
            objSheet.Cells(iRow, 2).Value = strText
            ' 次の行に移る
            iRow = iRow + 1
        End If
    End With
End With

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中