【Excel】請求書メールを自動作成

取引先毎に請求書メールを作成するのは大変です。

テンプレート文さえ作れば宛先や添付するファイルを自動判定し、メール作成してくれるExcelファイルを作ってみました。

このエクセルファイルの作り方

①マクロを使えるようにする
マクロを使えるようにする」を参照

②ボタンを配置する
 ※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「CreateEmail」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub CreateEmail()

    Dim oApp       As Object
    Dim objMail    As Object
    
    Dim subjectBodyWorksheet As Object: Set subjectBodyWorksheet = ThisWorkbook.Worksheets("件名・本文")
    Dim subject As String: subject = subjectBodyWorksheet.Cells(1, 2).Value
    Dim body As String: body = subjectBodyWorksheet.Cells(2, 2).Value
    Dim attachmentPath As String: attachmentPath = subjectBodyWorksheet.Cells(3, 2).Value
    
    Dim firstRow As Long: firstRow = 2
    Dim lastRow As Long: lastRow = ThisWorkbook.Worksheets("宛先リスト").Cells(Rows.Count, 1).End(xlUp).Row
    Dim companyNameRow As Integer: companyNameRow = 1
    Dim departmentNameRow As Integer: departmentNameRow = 2
    Dim staffNameRow As Integer: staffNameRow = 3
    Dim honorificTitleRow As Integer: honorificTitleRow = 4
    Dim mailAddressRow As Integer: mailAddressRow = 5
    
    
    
    For y = firstRow To lastRow
       Dim addressListWorksheet As Object: Set addressListWorksheet = ThisWorkbook.Worksheets("宛先リスト")
       
       Dim companyName As String: companyName = addressListWorksheet.Cells(y, companyNameRow).Value
       Dim departmentName As String: departmentName = addressListWorksheet.Cells(y, departmentNameRow).Value
       Dim staffName As String: staffName = addressListWorksheet.Cells(y, staffNameRow).Value
       Dim honorificTitle As String: honorificTitle = addressListWorksheet.Cells(y, honorificTitleRow).Value
       Dim mailAddress As String: mailAddress = addressListWorksheet.Cells(y, mailAddressRow).Value
    
       'メールアドレス列がからの場合は飛ばす
       If mailAddress = "" Then
          GoTo Continue
       End If
    
       'メールオブジェクト生成
       On Error Resume Next
       Set oApp = GetObject(, "Outlook.Application")
       On Error GoTo 0
       If oApp Is Nothing Then
          Set oApp = CreateObject("Outlook.Application")
          oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
       End If
       Set objMail = oApp.CreateItem(0)
    
       '各変数の置換
       Dim adjustBody As String: adjustBody = body
       adjustBody = Replace(adjustBody, "&CompanyName", companyName)
       adjustBody = Replace(adjustBody, "&DepartmentName", departmentName)
       adjustBody = Replace(adjustBody, "&StaffName", staffName)
       adjustBody = Replace(adjustBody, "&HonorificTitle", honorificTitle)
    
       '各メールの要素をセット
       With objMail
          .To = mailAddress
          .subject = subject
          .body = adjustBody
          .BodyFormat = 1
       End With
       
       '請求書添付
       AttachFile objMail, attachmentPath, companyName
        'メール表示
       objMail.display
    
Continue:
    Next y
    
    
    Set objMail = Nothing
    Set oApp = Nothing
End Sub

Sub AttachFile(ByVal objMail As Object, ByVal attachmentPath As String, ByVal companyName As String)

    If attachmentPath = "" Then
        Exit Sub
    End If
    

    Dim path, fso, file, files
    
        'ファイル格納フォルダ
        path = attachmentPath
    
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set files = fso.GetFolder(path).files
    
            'フォルダ内の全ファイルをループ
            For Each file In files
    
                'companyNameを含むファイルを特定
                If InStr(file.Name, companyName) >= 1 Then
    
                    objMail.Attachments.Add (file.path)
    
                End If
            Next file
End Sub

【Excel】メルマガを自動作成する

複数宛先への個別メールを自動作成するExcelファイルを作成してみました。
画像添付にも対応しています。

このエクセルファイルの作り方

①マクロを使えるようにする
マクロを使えるようにする」を参照

②ボタンを配置する
 ※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「CreateEmail」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub CreateEmail()

    Dim oApp       As Object
    Dim objMAIL    As Object
    
    Dim subjectBodyWorksheet As Object: Set subjectBodyWorksheet = ThisWorkbook.Worksheets("件名・本文")
    Dim subject As String: subject = subjectBodyWorksheet.Cells(1, 2).Value
    Dim body As String: body = subjectBodyWorksheet.Cells(2, 2).Value
    Dim mailMagazinePath As String: mailMagazinePath = subjectBodyWorksheet.Cells(3, 2).Value
    
    Dim firstRow As Long: firstRow = 2
    Dim lastRow As Long: lastRow = ThisWorkbook.Worksheets("宛先リスト").Cells(Rows.Count, 1).End(xlUp).Row
    Dim nameRow As Integer: nameRow = 1
    Dim mailAddressRow As Integer: mailAddressRow = 2
    
    '画像コピー
    Dim picture As shape: Set picture = CopyPicture(mailMagazinePath)
    
    '宛先分繰り返し
    For y = firstRow To lastRow
        Dim addressListWorksheet As Object: Set addressListWorksheet = ThisWorkbook.Worksheets("宛先リスト")
        
        '氏名とメールアドレス取得
        Dim name As String: name = addressListWorksheet.Cells(y, nameRow).Value
        Dim mailAddress As String: mailAddress = addressListWorksheet.Cells(y, mailAddressRow).Value
        
        'メールアドレス列がからの場合は飛ばす
        If mailAddress = "" Then
           GoTo Continue
        End If
        
        'メールオブジェクト生成
        On Error Resume Next
        Set oApp = GetObject(, "Outlook.Application")
        On Error GoTo 0
        If oApp Is Nothing Then
           Set oApp = CreateObject("Outlook.Application")
           oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
        End If
        Set objMAIL = oApp.CreateItem(0)
        
        '変数の置換
        Dim adjustBody As String: adjustBody = body
        adjustBody = Replace(adjustBody, "&Name", name)
        
        '各メールの要素をセットして表示
        With objMAIL
           .To = mailAddress
           .subject = subject
           .body = adjustBody
           .BodyFormat = 3
           .display
        End With
        
        '最終位置を取得して画像を貼り付け
        If Not (picture Is Nothing) Then
            Dim endPosition As Integer: endPosition = objMAIL.GetInspector.WordEditor.Characters.Count - 1
            oApp.ActiveInspector.WordEditor.Range(endPosition, endPosition).Paste
            Application.CutCopyMode = True
        End If
        
        '★自動で送信したい場合は↓の「'」を外してください★
        'objMail.Send
     
Continue:
    Next y
    
    '画像シートの画像を削除
    If Not (picture Is Nothing) Then
        picture.Delete
    End If
     
    Set objMAIL = Nothing
    Set oApp = Nothing
End Sub

Function CopyPicture(ByVal mailMagazinePath As String) As shape

    
    If mailMagazinePath = "" Then
       Exit Function
    End If
    

     '画像を画像シートに配置
    Dim picture As shape: Set picture = ThisWorkbook.Worksheets("画像").Shapes.AddPicture(Filename:=mailMagazinePath, _
                                                                    LinkToFile:=True, _
                                                                    SaveWithDocument:=False, _
                                                                    Left:=Selection.Left, _
                                                                    Top:=Selection.Top, _
                                                                    Width:=0, _
                                                                    Height:=0)
                                                                    
    '画像を元のサイズにしてコピー
    With picture
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        .Copy
    End With
    
    Set CopyPicture = picture

End Function

【Excel】アドインを作ってみる

Excelのアドイン機能を活用することで、普段よく行う操作をワンクリックでできるようになります。
今日は、テーブルの自動作成アドインを作っていきたいと思います。

このエクセルファイルの作り方

①マクロを使えるようにする(既に設定済の方は②に進んでください)
マクロを使えるようにする」を参照

②「マクロの記録」ボタンを押します。(マクロ名は何でもいいですが、今回は「Table」とします)

③テーブルを作成します

④「記録終了」を押します。

⑤「Alt + F8」を押して、「編集」を押します。(ソースコードが表示されます)

⑥ソースコードを微調整していきます。以下のソースをペーストします。

Sub Table()
    '特定のCellではなく選択範囲に罫線を描画する(Selectionというのが選択範囲)
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    'タイトルを塗りつぶし(選択範囲の先頭行のみ)
    Range(Selection(1), Selection(1).Offset(0, Selection.Columns.Count - 1)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    'タイトルを描画(選択範囲の先頭行のみ)※これはなくてもいいです
    For col = Selection(1).Column To Selection(1).Offset(0, Selection.Columns.Count - 1).Column
        Cells(Selection(1).Row, col) = "Col" & col - Selection(1).Column + 1
    Next col
End Sub

⑦ファイルの種類で「Excelアドイン(*.xlam)」を選択して保存します。

⑧「Excelアドイン」ボタンから、作成したアドイン(Table)を有効にします。

⑨「ファイル」を押します。

⑩「オプション」を押します。

⑪「クイックアクセスツールバー」に今回作成した「Table」を追加します。

⑫「クイックアクセスツールバー」のボタンから、テーブルを自動作成できるようになります。

【Excel】メールを自動作成する

Excelで情報共有しており、Excelに追記した内容をメールで共有するケースがあるかと思います。

面倒なメール作成を自動でできるようにしてみました。
件名やメール本文は微調整してご利用ください。

このエクセルファイルの作り方

①マクロを使えるようにする
マクロを使えるようにする」を参照

②ボタンを配置する
 ※ ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

③ボタン配置時の以下の画面で「マクロ名」を「CreateEmail」として「新規作成」を押す

④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub CreateEmail()
Dim oApp       As Object
Dim objMAIL    As Object
Dim messageList(1) As String
Dim n          As Long
Dim fullName As String
Dim firstName As String

On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
End If

fullName = Application.UserName
firstName = Mid(fullName, 1, InStr(fullName, " ") - 1)

Set objMAIL = oApp.CreateItem(0)
'メールに載せるメッセージ本文'
messageList(0) = "お疲れ様です。" & firstName & "です。" & vbCrLf & vbCrLf & _
"共有ファイルNo." & Cells(3, 3).Value & "に追記を行いました。" & vbCrLf & _
"タイミングを見てご確認ください。" & vbCrLf & vbCrLf & _
"<\ShareServer\メールを自動作成する.xlsm>" & vbCrLf

messageList(1) = vbCrLf & "     以上、宜しくお願い致します。"

Dim adress As String
Dim i As Long
For i = 1 To 50

adress = adress + ThisWorkbook.Worksheets("宛先").Cells(i + 1, 2).Value
adress = adress + " ;"

Next i

objMAIL.To = adress
'件名'
objMAIL.Subject = "共有ファイルNo." & Cells(3, 3).Value & "を追加しました"
objMAIL.BodyFormat = 2 'HTML形式
objMAIL.Body = messageList(0) & messageList(1)
objMAIL.display

n = Len(messageList(0))
ActiveSheet.Range(Cells(Cells(3, 3) + 5, 2), Cells(Cells(3, 3) + 5, 5)).Copy
oApp.ActiveInspector.WordEditor.Range(n, n).Paste
Application.CutCopyMode = False

Set objMAIL = Nothing
Set oApp = Nothing
End Sub

【Excel】QRコードを一括作成する

「Google Charts API」を利用して、URL等を一括でQRコードにするプログラムを作成します。
商品パッケージやパンフレットなどへの添付にご活用ください。

このエクセルファイルの作り方

①マクロを使えるようにする
マクロを使えるようにする」を参照

②URL、QRコードの表を作成

③ボタン配置時の以下の画面で「マクロ名」を「CreateQrcode」として「新規作成」を押す

④Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub CreateQrcode()
    '開始行
    Dim firstRow As Long: firstRow = 3
    '最終行の取得
    Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row

    'firstRow~lastRowまで繰り返し(途中エラーが出た場合も止めずに最後まで処理)
    On Error Resume Next
        For i = firstRow To lastRow

            'QRコード表示セルの高さなどを調整
            With Cells(i, "B")
                .RowHeight = 65
                .VerticalAlignment = xlTop '上詰め
            End With

            'GoogleAPIでQRコードを作成
            Set qr = ActiveSheet.Pictures _
                    .Insert("http://chart.apis.google.com/chart?cht=qr&chs=80x80&chl=" _
                            + Cells(i, "A").Value)

            'QRコードの表示位置を指定
            With qr
                .Top = Cells(i, "B").Top + 2
                .Left = Cells(i, "B").Left + 2
            End With
        Next i
    On Error GoTo 0
End Sub