【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】Delete時に元の関数をセット

VLOOKUP 関数等を利用している場合、スポット的に直接値を入れたいケースがあると思います。

直接入れた値の削除時にもともと設定してあったVLOOKUP関数を再セットするプログラムを作成します。

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

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

②VLOOKUP関数の参照元、先を作成

③「Alt + F8」を押して表示される以下の画面で「マクロ名」を「FunctionDisplayOnDeletion」として「作成」を押す

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

Sub FunctionDisplayOnDeletion()
    Dim searchValueRow As Integer: searchValueRow = 1 '★検索値列
    Dim startFuncRow As Integer: startFuncRow = 2 '★VLOOKUP関数設定開始行
    Dim startFuncCol As Integer: startFuncCol = 2 '★VLOOKUP関数設定開始列
    Dim endFuncCol As Integer: endFuncCol = 3 '★VLOOKUP関数設定終了列
    
    Dim c As Range, i As Long
    For Each c In Selection
        If c.Row >= startFuncRow _
           And c.Column >= startFuncCol _
           And c.Column <= endFuncCol Then
            c.Value = "=IFERROR(VLOOKUP(" & Cells(c.Row, searchValueRow).Address(False, False) & ",品目情報!$A$2:$C$5," & c.Column & ",FALSE),"""")"
        Else
            c.Value = ""
        End If
    Next c
    
End Sub
Sub AutoActivateSheet_Name()
    'DeleteKeyを押すと「FunctionDisplayOnDeletion」マクロ実行
    Application.OnKey "{Delete}", "FunctionDisplayOnDeletion"
    Application.OnKey "^{Delete}", "FunctionDisplayOnDeletion"
End Sub
Sub AutoDeactivateSheet_Name()
    'DeleteKeyへの割り当て解除
    Application.OnKey "{Delete}"
    Application.OnKey "^{Delete}"
End Sub
Sub Auto_Open()
    '「見積り入力」シートがアクティブになったら「AutoActivateSheet_Name」マクロ実行
    Worksheets("見積り入力").OnSheetActivate = "AutoActivateSheet_Name"
    '「見積り入力卸」シート以外がアクティブになったら「AutoDeactivateSheet_Name」マクロ実行
    Worksheets("見積り入力").OnSheetDeactivate = "AutoDeactivateSheet_Name"
End Sub

【Excel】Excelで実地棚卸

Excelで実地棚卸を管理するプログラムを作成します。

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

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

②実地棚卸の表を作成

③ 「Alt + F8」を押して表示される以下の画面で「マクロ名」を「SearchGoods_InputInventoryQuantity」として「作成」を押す

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


Public enterFlg As Boolean

Sub SearchGoods_InputInventoryQuantity()

'検索文字入力行・列

Dim searchValueRow As Integer: searchValueRow = 1 '★

Dim searchValueCol As Integer: searchValueCol = 2 '★

'検索対象列

Dim searchTargetCol As Integer: searchTargetCol = 2 '★

'検索文字'

Dim searchValue As String: searchValue = Cells(searchValueRow, searchValueCol).Value

'棚卸数量入力行・列

Dim inventoryQuantityRow As Integer: inventoryQuantityRow = 2 '★

Dim inventoryQuantityCol As Integer: inventoryQuantityCol = 2 '★

'棚卸数量転記対象列

Dim copyQuantityTargetCol As Integer: copyQuantityTargetCol = 8 '★

'商品コード未入力メッセージ'

Dim codeNotEnteredMessage As String: codeNotEnteredMessage = "商品コードを入力してください" '★

'重複メッセージ'

Dim duplicateMessage As String: duplicateMessage = "既に入力があります" '★

'開始行

Dim startRow As Integer: startRow = 5 '★

'終了行

Dim lastRow As Integer: lastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1

'アクティブCellが商品コードまたは棚卸数量欄でなければアクティブセルの移動のみ

Dim activeRow As Integer: activeRow = ActiveCell.Row

Dim activeCol As Integer: activeCol = ActiveCell.Column

'商品コード検索

If activeRow = searchValueRow And activeCol = searchValueCol Then

For i = startRow To lastRow Step 1

If Cells(i, searchTargetCol).Value <> searchValue And searchValue <> "" Then

Rows(i).Hidden = True

Else

Rows(i).Hidden = False

End If

Next

Cells(activeRow + 1, activeCol).Select

'棚卸数量入力(1回目)

ElseIf activeRow = inventoryQuantityRow And activeCol = inventoryQuantityCol And enterFlg = False And Cells(inventoryQuantityRow, inventoryQuantityCol) <> "" Then

If Cells(searchValueRow, searchValueCol).Value = "" Then

MsgBox codeNotEnteredMessage

Cells(searchValueRow, searchValueCol).Select

Exit Sub

End If

For i = startRow To lastRow Step 1

If Cells(i, copyQuantityTargetCol).Value = "" And Rows(i).Hidden = False Then

Cells(i, copyQuantityTargetCol).Value = Cells(inventoryQuantityRow, inventoryQuantityCol)

ElseIf Cells(i, copyQuantityTargetCol).Value <> "" And Rows(i).Hidden = False Then

MsgBox duplicateMessage

Exit Sub

End If

Next

enterFlg = True

'棚卸数量入力(2回目)

ElseIf activeRow = inventoryQuantityRow And activeCol = inventoryQuantityCol Then

For i = startRow To lastRow Step 1

Rows(i).Hidden = False

Next

Cells(inventoryQuantityRow, inventoryQuantityCol) = ""

Cells(searchValueRow, searchValueCol).Select

enterFlg = False

Else

Cells(activeRow + 1, activeCol).Select

Exit Sub

End If

End Sub

Sub Auto_Open()

'「実地棚卸」シートがアクティブになったら「AutoActivateSheet_Name」マクロ実行

Worksheets("実地棚卸").OnSheetActivate = "AutoActivateSheet_Name"

'「実地棚卸」シート以外がアクティブになったら「AutoDeactivateSheet_Name」マクロ実行

Worksheets("実地棚卸").OnSheetDeactivate = "AutoDeactivateSheet_Name"

End Sub

Sub AutoActivateSheet_Name()

'Enterを押すと「SearchGoods_InputInventoryQuantity」マクロ実行

Application.OnKey "~", "SearchGoods_InputInventoryQuantity"

Application.OnKey "{Enter}", "SearchGoods_InputInventoryQuantity"

End Sub

Sub AutoDeactivateSheet_Name()

'テンキーのEnterへの割り当て解除

Application.OnKey "{Enter}"

'大きいEnterへの割り当て解除

Application.OnKey "~"

End Sub

【Excel】セルに名前を付けてハイパーリンクを設定する

名前の定義によってセルに名前を付け、その名前に対してハイパーリンクを設定する方法です。
座標を指定したハイパーリンクとは異なり、対象セルの行や列が変動した場合も影響を受けずにリンクする事が可能です。

【前提】「2018」シートから「基本情報」シートへリンクする

①セルに名前を付ける

②名前を指定したハイパーリンクを設定

【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