【Excel】全シートのセルをA1に移動・倍率100%にするアドイン

ExcelファイルでカーソルをA1へ移動するのが流行っているらしいのでアドインを作ってみました。

https://twitter.com/Rina_pan_pan/status/1704421257591365676

動作イメージ

設定方法

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

②アドインファイルをダウンロード

③アドインを追加
過去の記事を参考に追加してください。

ソースコード

Sub ObserveManners()
    Dim ws As Worksheet
    '全てのシートでA1セルを指定し、倍率を100%に変更。
    For Each ws In Worksheets
        ws.Select
        ws.Range("A1").Select
        ActiveWindow.Zoom = 100
    Next
    '1つ目のシートへ移動。
    Sheets(1).Select
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 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