Excel マクロ・VBA 困ったとき用(更新ver1.1)

履歴

実施したことを残していく
業務で困った際の参考にできることも理想とする

• 20241031(更新ver1.0):値の検索までを投稿
• 20241117(更新ver1.1):Outlookメール抽出マクロ(未完成)の追加

コード

Sub こんにちは()
'メッセージボックスに出力

MsgBox "こんにちは！"

End Sub


Sub A1セルにこんにちは()
'A１セルの内容を「こんにちは」に変更する
Range("A1").Value = "こんにちは"

End Sub

Sub セルの合計()
'A2セルからA11セルの合計をメッセージボックスに表示
Dim 範囲 As Range                                                               'As Rangeは特定のセルやセルの範囲を扱う際に使う
Dim セル As Range
Dim 合計 As Double                                                             'Doubleは少数を扱えるうえに、大きな数値も扱える

'合計したいセル範囲をA2からA11に指定する
Set 範囲 = Range("A2:A11")                                                  'set オブジェクト範囲 = オブジェクト　今回は範囲に("A2:A11")を代入している

'範囲内の各セルを順番に読み込んで、合計を計算する
For Each セル In 範囲                                                           '「For Each...Next」ループ：指定した範囲内のすべてのセルに対して順番に操作を行う処理
      If IsNumeric(セル.Value) Then                                           'セルの値が数値であるか確認する。数値であればTrue、数値でなければFalseを返す。
         合計 = 合計 + セル.Value                                               'セルの値が数値であれば、その値を今までの合計に加える。徐々に計算していく
      End If                                                                            '数値の時だけ処理する部分を終える。数値以外の場合は何もしない
    
Next セル                                                                             '次のセルに進む。このループを範囲内のすべてのセルで繰り返す。
      
      '　合計値をメッセージボックスで表示
      MsgBox "合計値は: " & 合計
      
End Sub

Sub 塗りつぶし()

Dim 範囲 As Range
Dim セル As Range

'チェックしたいセル範囲を指定
Set 範囲 = Range("a1:A10")

'範囲内の各セルを順番に読み込む
For Each セル In 範囲
      'セルの値が50以上かチェックする
      If セル.Value >= 50 Then
         '条件を満たす場合、背景色を黄色に
         セル.Interior.Color = RGB(255, 255, 0)                        'Interiorはセルの見た目を変更したい時に使う
         
      End If
Next セル

End Sub

Sub 値の検索()

       Dim 範囲 As Range
       Dim セル As Range
       Dim 検索値 As Variant
       Dim 見つけた As Boolean
       
       '検索したいセル範囲を指定
       Set 範囲 = Range("B1:B20")
       
       'ユーザに検索したい値を入力してもらう
       検索値 = InputBox("検索したい値を入力してね:")
       
       '見つけたフラグを最初はFalseにしておく
       見つけた = False
       
       '範囲内の各セルを順番にチェックする
       For Each セル In 範囲
            If セル.Value = 検索値 Then
               '値が見つかった場合、セルを緑色で協調表示
               セル.Interior.Color = RGB(144, 238, 144)
               見つけた = True
            End If
        Next セル

End Sub

Excelシート

• Outlookメール抽出マクロ(未完成)
  特定のフォルダから日時指定を行い、件名と受信時刻を抽出する。

Sub ExtractEmailsFromSubfoldersWithDateFilter()
    Dim olApp As Object
    Dim olNamespace As Object
    Dim olInbox As Object
    Dim olTestFolder As Object
    Dim olKenshoFolder As Object
    Dim olMail As Object
    Dim ws As Worksheet
    Dim rowIndexKensho As Integer
    Dim rowIndexTest As Integer
    Dim startDate As Date
    Dim endDate As Date

    ' 抽出する日付範囲を設定
    startDate = DateValue("2024/11/1") ' 抽出を開始する日付
    endDate = DateValue("2024/11/18") ' 抽出を終了する日付

    ' Excelのシート2に設定
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sheet2") ' Sheet2を設定
    On Error GoTo 0

    ' シート確認
    If ws Is Nothing Then
        MsgBox "Sheet2が存在しません。シート名を確認してください。", vbExclamation
        Exit Sub
    End If

    ' Outlookアプリケーションを取得（既存のセッションのみ）
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application") ' 既存のOutlookセッションを取得
    On Error GoTo 0

    ' Outlookが開いていない場合はエラーメッセージを表示して終了
    If olApp Is Nothing Then
        MsgBox "Outlookが開いていません。Outlookを起動してから再試行してください。", vbExclamation
        Exit Sub
    End If

    ' 名前空間を取得する
    Set olNamespace = olApp.GetNamespace("MAPI") ' MAPI名前空間を取得

    ' 受信トレイを取得
    Set olInbox = olNamespace.GetDefaultFolder(6) ' 受信トレイフォルダを取得

    ' 検証フォルダを取得
    On Error Resume Next
    Set olKenshoFolder = olInbox.Folders("検証") ' 受信トレイ内の「検証」フォルダを取得
    If olKenshoFolder Is Nothing Then
        MsgBox "検証フォルダが見つかりません。", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    ' テストフォルダを取得
    On Error Resume Next
    Set olTestFolder = olInbox.Folders("テスト") ' 受信トレイ内の「テスト」フォルダを取得
    If olTestFolder Is Nothing Then
        MsgBox "テストフォルダが見つかりません。", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    ' 出力開始位置
    rowIndexKensho = 3 ' 検証用データの開始行
    rowIndexTest = 3 ' テスト用データの開始行

    ' 検証フォルダのメールをシートに記録
    For Each olMail In olKenshoFolder.Items
        If olMail.Class = 43 Then ' メールアイテムであることを確認
            If olMail.ReceivedTime >= startDate And olMail.ReceivedTime <= endDate + 1 Then ' 指定した日付範囲内のメールか確認
                ws.Cells(rowIndexKensho, 1).Value = olMail.Subject ' 件名をシートに記録
                ws.Cells(rowIndexKensho, 2).Value = olMail.ReceivedTime ' 受信日時をシートに記録
                rowIndexKensho = rowIndexKensho + 1 ' 次の行に移動
            End If
        End If
    Next olMail

    ' テストフォルダのメールをシートに記録
    For Each olMail In olTestFolder.Items
        If olMail.Class = 43 Then ' メールアイテムであることを確認
            If olMail.ReceivedTime >= startDate And olMail.ReceivedTime <= endDate + 1 Then ' 指定した日付範囲内のメールか確認
                ws.Cells(rowIndexTest, 3).Value = olMail.Subject ' 件名をシートに記録
                ws.Cells(rowIndexTest, 4).Value = olMail.ReceivedTime ' 受信日時をシートに記録
                rowIndexTest = rowIndexTest + 1 ' 次の行に移動
            End If
        End If
    Next olMail
End Sub

テスト用（未確認）

' 最初のサブルーチン：日付リストを作成
Sub CreateDateList()
    Dim ws As Worksheet
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Date
    Dim rowIndex As Integer
    
    ' シート3に設定
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sheet3")
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "Sheet3が存在しません。シート名を確認してください。", vbExclamation
        Exit Sub
    End If
    
    ' 開始日と終了日を設定
    startDate = DateValue("2024/11/1")
    endDate = DateValue("2024/11/13")
    
    ' 行インデックスの初期化
    rowIndex = 2
    
    ' 日付のリストを作成
    ws.Cells.ClearContents ' 既存の内容をクリア
    ws.Cells(1, 1).Value = "日付"
    currentDate = startDate
    Do While currentDate <= endDate
        ws.Cells(rowIndex, 1).Value = currentDate
        currentDate = currentDate + 1
        rowIndex = rowIndex + 1
    Loop
    MsgBox "日付リストを作成しました。シート3の日付を選択してから、マクロを実行してください。"
End Sub

' 次のサブルーチン：選択された日付のメール情報を出力
Sub ExtractSelectedDateEmails()
    Dim olApp As Object
    Dim olNamespace As Object
    Dim olInbox As Object
    Dim olTestFolder As Object
    Dim olKenshoFolder As Object
    Dim olMail As Object
    Dim ws As Worksheet
    Dim selectedDate As Date
    Dim mailList As Collection
    Dim item As Variant
    Dim tempItem As Variant
    Dim i As Long
    Dim j As Long

    ' シート3を取得
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Sheet3")
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "Sheet3が存在しません。", vbExclamation
        Exit Sub
    End If

    ' 日付が選択されているか確認
    If TypeName(Selection) <> "Range" Or IsEmpty(Selection.Value) Then
        MsgBox "日付を選択してください。", vbExclamation
        Exit Sub
    End If
    
    selectedDate = Selection.Value

    ' Outlookアプリケーションを取得（既存のセッションのみ）
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0

    ' Outlookが開いていない場合はエラーメッセージを表示して終了
    If olApp Is Nothing Then
        MsgBox "Outlookが開いていません。Outlookを起動してから再試行してください。", vbExclamation
        Exit Sub
    End If

    ' 名前空間を取得する
    Set olNamespace = olApp.GetNamespace("MAPI")

    ' 受信トレイを取得
    Set olInbox = olNamespace.GetDefaultFolder(6)

    ' 検証フォルダとテストフォルダを取得
    On Error Resume Next
    Set olKenshoFolder = olInbox.Folders("検証")
    Set olTestFolder = olInbox.Folders("テスト")
    If olKenshoFolder Is Nothing Or olTestFolder Is Nothing Then
        MsgBox "検証フォルダまたはテストフォルダが見つかりません。", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    ' メールを一時的に保存するコレクションを作成
    Set mailList = New Collection

    ' 指定された日付のメールを収集
    For Each olMail In olKenshoFolder.Items
        If olMail.Class = 43 Then
            If Format(olMail.ReceivedTime, "yyyy/mm/dd") = Format(selectedDate, "yyyy/mm/dd") Then
                mailList.Add Array(olMail.Subject, olMail.ReceivedTime)
            End If
        End If
    Next olMail

    For Each olMail In olTestFolder.Items
        If olMail.Class = 43 Then
            If Format(olMail.ReceivedTime, "yyyy/mm/dd") = Format(selectedDate, "yyyy/mm/dd") Then
                mailList.Add Array(olMail.Subject, olMail.ReceivedTime)
            End If
        End If
    Next olMail

    ' ソートされたメールをシートに出力
    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Sheets("Sheet2")
    wsOutput.Cells.ClearContents ' Clear contents
    wsOutput.Cells(2, 1).Value = "件名"
    wsOutput.Cells(2, 2).Value = "受信日時"
    For i = 1 To mailList.Count
        wsOutput.Cells(i + 2, 1).Value = mailList(i)(0) ' 件名
        wsOutput.Cells(i + 2, 2).Value = mailList(i)(1) ' 受信日時
    Next i

    MsgBox "指定した日付のメールがSheet2に出力されました。"
End Sub