【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】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

【Excel】背の順や成績順で座席表を自動作成

背の小さい順や成績の悪い順で、座席を割り振りたいケースがあると思います。
今回は生徒の名簿一覧から背の順で座席を割り振る方法を紹介させて頂きます。

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

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

②生徒情報の表を作成

③座席表を作成

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

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

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

Sub StartSeatSelection()

Dim noCol As Integer: noCol = 1 '★
Dim nameCol As Integer: nameCol = 2 '★
Dim heightCol As Integer: heightCol = 3 '★

Dim startRow As Integer: startRow = 2 '★
Dim lastRow As Integer: lastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

Dim studentList As Dictionary
Set studentList = New Dictionary

Dim tempStudentList As Dictionary
Set tempStudentList = New Dictionary

'「生徒情報」シートの内容を1行ずつ読み込み、studentListに身長順で格納します。
For i = startRow To lastRow Step 1

    Set tempStudentList = studentList
    Set studentList = New Dictionary

    Dim no As String
    no = Cells(i, noCol).Value
    Dim name As String
    name = Cells(i, nameCol).Value
    Dim height As String
     height = Cells(i, heightCol).Value
    
    If IsEmpty(no) Then
        MsgBox "生徒番号が空欄です。"
    End If
    If Not IsNumeric(no) Then
        MsgBox no & ":生徒番号には数値を指定してください。"
    End If
        
    If IsEmpty(name) Then
        MsgBox "氏名が空欄です。"
    End If
        
     If IsEmpty(height) Then
        MsgBox "身長が空欄です。"
    End If
    If Not IsNumeric(height) Then
        MsgBox height & ":身長には数値を指定してください。"
    End If
    
    If tempStudentList.Count > 0 Then
        For Each tempStudent In tempStudentList.Items
            If (tempStudent(2) > height Or (tempStudent(2) = height And tempStudent(0) > no)) And Not studentList.Exists(no) Then
                studentList.Add no, Array(no, name, height)
            End If
            
            studentList.Add tempStudent(0), Array(tempStudent(0), tempStudent(1), tempStudent(2))
         Next tempStudent
    End If
    

    If Not studentList.Exists(no) Then
        studentList.Add no, Array(no, name, height)
    End If

Next

'studentListを基に、座席に名前をあてはめます。

Dim startSheetRow As Integer: startSheetRow = 4 '★
Dim lastSheetRow As Integer: lastSheetRow = 14 '★
Dim startSheetCol As Integer: startSheetCol = 2 '★
Dim lastSheetCol As Integer: lastSheetCol = 12 '★

Dim targetRow As Integer
Dim targetCol As Integer

Dim studentListCnt As Integer: studentListCnt = 0 '★

For targetRow = startSheetRow To lastSheetRow Step 2
    For targetCol = startSheetCol To lastSheetCol Step 2
    
    Worksheets("座席表").Cells(targetRow, targetCol).Value = studentList.Items(studentListCnt)(1)
    studentListCnt = studentListCnt + 1
    
    Next targetCol
    
Next targetRow

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