【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】CSVファイルをリアルタイム読み取り

VBAを利用して、随時更新されるcsvファイルをリアルタイムで読み取るプログラムを作成しました。
随時更新される売上データを題材に作成しています。

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

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

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

②元データとするCSVファイルを用意

③読み取ったCSVを書き込むテーブルを作成

④テーブルの値を集計する任意のピボットグラフを作成

⑤集計開始をするボタンを用意

※ボタンの追加方法は「以前の記事」を参考

⑥マクロを作成する

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

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

必要に応じて「★」のついた箇所を変更

Sub Addup_Click()
    Call ReadCSV
End Sub

Function ReadCSV()
    '★読み込み対象ファイルの絶対パスを指定
    Dim filePass  As String: filePass = "C:\SalesData.csv"
    '★書き込みを開始する行・列を指定
    Dim startRow As Integer: startRow = 2
    Dim startCol As Integer: startCol = 1
    '★定期実行する間隔を指定
    Dim waitSec As Single: waitSec = 5
    
    Dim targetRow As Integer: targetRow = startRow
    Dim targetCol As Integer: targetCol = startCol
    Dim rowBuf  As String
    Dim cellBufList As Variant
    
    Open filePass For Input As #1
    
    '全行読み込み終わるまで繰り返し
    Do Until EOF(1)
        '1行読み込み
        Line Input #1, rowBuf
        '読みこんだ1行をカンマで区切り配列化
        cellBufList = Split(rowBuf, ",")
    
        '配列分繰り返し
        For Each cellBuf In cellBufList
            Cells(targetRow, targetCol).Value = cellBuf
            '次の列へ
            targetCol = targetCol + 1
        Next cellBuf
        
        '次の行へ
        targetCol = startCol
        targetRow = targetRow + 1
    Loop
    Close #1
    
    'ピボットテーブルの更新
    Dim pvt As PivotTable

    For Each pvt In ActiveSheet.PivotTables
        pvt.PivotCache.Refresh
    Next
    
    '待機処理
    Dim Tm As Single
    Tm = Timer
    
    Do
        DoEvents
    Loop Until Timer > Tm + waitSec
    
    '再帰
    Call ReadCSV
    
End Function

【Excel】足し算の問題を作る

①UserFormの作成

②各ボタン押下時の処理を記載
※例外処理は省略

○「出題!」ボタン押下時のソース

Private Sub CommandButton1_Click()
'「出題!」ボタン押下時の処理

'一つ目のラベルに乱数をセット(1~9)
Label1.Caption = Str(Int(9 * Rnd + 1))

'二つ目のラベルに乱数をセット(1~9)
Label2.Caption = Str(Int(9 * Rnd + 1))

'回答入力欄にフォーカスセット
TextBox1.SetFocus

'正解判定ラベルを空に
Label3.Caption = ""

End Sub<span data-mce-type="bookmark" style="display: inline-block; width: 0px; overflow: hidden; line-height: 0;" class="mce_SELRES_start"></span>

○「採点!」ボタン押下時のソース

Private Sub CommandButton2_Click()
'「採点!」ボタン押下時の処理

'正解なら「〇」不正解なら「×」を表示
If (Val(Label1.Caption) + Val(Label2.Caption) = TextBox1.Text) Then
Label3.Caption = "○"
Else
Label3.Caption = "×"
End If

End Sub

【Excel】印刷設定画面を起動する(初期値を指定する)

まずは印刷設定画面を起動する」を参照

「Application.Dialogs(xlDialogPrint).Show」メソッドに以下の引数を渡すことで初期値を設定可能

arg1 = 印刷範囲(1:すべて、2:ページ指定)
arg2 = 開始
arg3 = 終了
arg4 = 部数
arg5 = 簡易印刷(0:しない、1:する) ※1:するにした場合は罫線などが表示されない
arg6 = 印刷プレビュー(Excel5以降のVBAの場合機能しません。代わりにxlDialogPrintPreviewダイアログを使用してください。)
arg7 = メモ印刷(1:シートとセルの値のみ、2:コメントも
arg8 = カラー印刷※Mac用
arg9 = 紙送り(1:連続紙カセット用、2:カットシートまたは手動フィード)※Mac用
arg10 = 印刷品質(dpi)
arg11 = 縦方向の解像度(dpi)
arg12 = 印刷対象(1:選択した部分、2:ブック全体、3:選択したシート、4:テーブル)
arg13 = プリンタ名
arg14 = ファイルへ出力(False:チェックOFF、True:チェックON)
arg15 = 部単位で印刷(False:チェックOFF、True:チェックON)

●ソースコード(実装例) ※設定不要な部分は省略可

Sub 印刷ダイアログ()
Application.Dialogs(xlDialogPrint).Show _
Arg1:=2, _
Arg2:=1, _
Arg3:=2, _
Arg4:=5, _
Arg5:=0, _
Arg6:=False, _
Arg7:=2, _
Arg8:=1, _
Arg9:=1, _
Arg10:=600, _
Arg11:=600, _
Arg12:=3, _
Arg13:="Microsoft Print to PDF", _
Arg14:=True, _
Arg15:=False
End Sub