소개

Excel에 작성된 정보를 검색하고 자동으로 Outlook 메일을 만드는 VBA를 만들었으므로 메모로 남겨 둡니다.

내용

Excel 파일로부터 송신측의 정보·수신처 정보를 취득한다.
받는 사람 목록을 필터링하면 표시된 받는 사람에게만 메일을 만들 수 있습니다.

Excel 파일 첫 번째 시트에 보낸 사람 정보

발신 주소
제목
CC
BCC
본문

Excel 파일 2시트에서 얻은 대상 정보

회 사 명
직책
이메일 주소
이름

실제 코드

make_mail.xlsm

    Sub Sample()
        '変数定義
        Dim OL As Outlook.Application
        Dim MI As Outlook.MailItem
        Dim R_Start As Integer, R_End As Integer
        Dim Rownum As Integer
        Dim Str As String
        Dim LastRow As Long
        Str = "様"

        'outlookアプリを指定
        Set OL = CreateObject("Outlook.Application")

        'フィルターがかかっている場合の処理
        If ActiveSheet.FilterMode = True Then

            '表示されている行のみをループ
            With Range("C1").CurrentRegion.Offset(1, 0)
                For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows
                    Rownum = R.Row
                    Set MI = OL.CreateItem(olMailItem)


                    MI.SentOnBehalfOfName = Worksheets("data").Range("B2")    '差出人
                    MI.Subject = Worksheets("data").Range("B3")    '件名
                    MI.To = Cells(Rownum, 6)    'To
                    MI.Cc = Worksheets("data").Range("B4")  'CC
                    MI.Bcc = Worksheets("data").Range("B5")    'BCC

                '本文
                  MI.Body = Cells(Rownum, 3) & vbCr _
                      & Cells(Rownum, 5) & Str & vbCr _
                      & Worksheets("data").Range("B6") & vbCr _



                  MI.Save
                'MI.Display    'メール表示
                Next R
            End With
            'メールのオブジェクトをリセット
            Set OL = Nothing
            Set MI = Nothing

            MsgBox "完了"

        'フィルターがかかっていない場合の処理
        Else
            R_Start = 2
            LastRow = Cells(Rows.Count, 3).End(xlUp).Row


            For R_Start = R_Start To LastRow

                Rownum = R_Start
                Set MI = OL.CreateItem(olMailItem)


                MI.SentOnBehalfOfName = Worksheets("data").Range("B2")    '差出人
                MI.Subject = Worksheets("data").Range("B3")    '件名
                MI.To = Cells(Rownum, 6)    'To
                MI.Cc = Worksheets("data").Range("B4")  'CC
                MI.Bcc = Worksheets("data").Range("B5")    'BCC


            '本文

              MI.Body = Cells(Rownum, 3) & vbCr _
                  & Cells(Rownum, 5) & Str & vbCr _
                  & Worksheets("data").Range("B6") & vbCr _

              MI.Save
            'MI.Display    'メール表示
            Next R_Start

        Set OL = Nothing
        Set MI = Nothing

        MsgBox "完了"

        End If

    End Sub

해설

필터링 시 처리

필터가 걸려 있을 때는 표시되어 있는 행만을 루프해 정보를 취득하고 있습니다.

    If ActiveSheet.FilterMode = True Then

            '表示されている行のみをループ
            With Range("C1").CurrentRegion.Offset(1, 0)
                For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows
                    Rownum = R.Row

template 시트 C열의 기업명을 기준으로 판정하고 있습니다.

    With Range("C1").CurrentRegion.Offset(1, 0)

.Resize(.Rows.Count - 1)　　　　　　  基準としているC1セルから一つ下がった行からのループ

SpecialCells(xlCellTypeVisible).Rowsで表示されている行を取得しています



    For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows

필터가 걸리지 않은 경우 처리

루프의 선두행을 R_Start에 대입합니다.

    R_Start = 2

루프의 마지막 행을 LastRow에 대입합니다.

기준으로 하는 열을 지정해, End(xlUp).Row 로 최종행을 취득하고 있습니다.

    LastRow = Cells(Rows.Count, 3).End(xlUp).Row