はじめに

こちらの記事は先回の記事の続きとなっています。

先回の記事はこちら
https://x.com/to_nakagawa/status/2064705380475945260?s=20

先回作成したHTMLコードで作成したアプリを
実務で使用しているExcelファイルに反映し、
同僚に使用、改善を進めていきました。

以下、作成したサンプル表の動画になります。

用意するもの
CodePen(コードペン）https://codepen.io/
ChatGPT（その他Gemini、 Copilot、などAI）https://chatgpt.com/ja-JP/
EXCEL(皆さんご存じマイクロソフト社表計算ソフト） https://www.microsoft.com/ja-jp/download

AIでVBAコードを作成
まずはChatGPTにサンプルファイルをコピーして共有します。
共有した上で依頼をしました。

そこで答えてくれたコードをVBAに入力をします。
返答コードはこちら

振分数量反映ボタンと数値の反映

Option Explicit

'------------------------------------------------------------
' 初回のみ実行：第１・２シートに「振分数量を反映」ボタンを作成します
'------------------------------------------------------------
Public Sub 第12シートにボタン作成()

Dim ws As Worksheet
Dim btn As Button
Dim shp As Shape

Set ws = ThisWorkbook.Worksheets("第１・２")

'同じボタンが既にある場合は削除して作り直す
For Each shp In ws.Shapes
    If shp.Name = "btnSheet2QtyReflect" Then
        shp.Delete
        Exit For
    End If
Next shp

'表の右側にボタンを配置
Set btn = ws.Buttons.Add( _
    Left:=ws.Range("V1").Left, _
    Top:=ws.Range("V1").Top, _
    Width:=150, _
    Height:=32)
    
With btn
    .Name = "btnSheet2QtyReflect"
    .Caption = "振分数量を反映"
    .OnAction = "Sheet2振分数量反映"
End With

MsgBox "第１・２シートにボタンを作成しました。", vbInformation

End Sub

'------------------------------------------------------------
' Sheet2の振分数量を、商品名・店舗名を参照して第１・２シートへ反映
'
' Sheet2想定：
' B1：商品名
' A列：店舗名
' E列：振分数量
'
' 第１・２シート想定：
' G列：商品名
' 11行目：店舗名見出し
' 商品名行 × 店舗名列の交点に振分数量を反映
'------------------------------------------------------------
Public Sub Sheet2振分数量反映()

Dim wsPlan As Worksheet
Dim wsData As Worksheet
Dim productName As String
Dim productCell As Range
Dim storeCell As Range
Dim lastSrcRow As Long
Dim r As Long
Dim storeName As String
Dim qty As Variant
Dim updateCount As Long
Dim missingStores As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False
Application.EnableEvents = False

Set wsPlan = ThisWorkbook.Worksheets("第１・２")
Set wsData = ThisWorkbook.Worksheets("Sheet2")

productName = Trim(CStr(wsData.Range("B1").Value))

If productName = "" Then
    MsgBox "Sheet2のB1に商品名がありません。", vbExclamation
    GoTo ExitHandler
End If

'第１・２シートのG列から商品名を完全一致で検索
Set productCell = wsPlan.Columns("G").Find( _
    What:=productName, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    MatchCase:=False)
    
If productCell Is Nothing Then
    MsgBox "第１・２シートのG列に商品名「" & productName & "」が見つかりません。", vbExclamation
    GoTo ExitHandler
End If

lastSrcRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row

If lastSrcRow < 3 Then
    MsgBox "Sheet2に反映対象データがありません。", vbExclamation
    GoTo ExitHandler
End If

For r = 3 To lastSrcRow

    storeName = Trim(CStr(wsData.Cells(r, "A").Value))
    qty = wsData.Cells(r, "E").Value
    
    If storeName <> "" Then
    
        '第１・２シートの11行目から店舗名を完全一致で検索
        Set storeCell = wsPlan.Rows(11).Find( _
            What:=storeName, _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            MatchCase:=False)
        
        If storeCell Is Nothing Then
            missingStores = missingStores & vbCrLf & "・" & storeName
        Else
            wsPlan.Cells(productCell.Row, storeCell.Column).Value = qty
            updateCount = updateCount + 1
        End If
        
    End If
    
Next r

If missingStores <> "" Then
    MsgBox "反映完了：" & updateCount & "件" & vbCrLf & vbCrLf & _
           "ただし、以下の店舗名は第１・２シートの11行目に見つかりませんでした。" & _
           missingStores, vbExclamation
Else
    MsgBox "反映完了：" & updateCount & "件" & vbCrLf & _
           "商品名「" & productName & "」の振分数量を第１・２シートに反映しました。", vbInformation
End If

ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox "エラーが発生しました。" & vbCrLf & Err.Description, vbCritical
Resume ExitHandler

End Sub

開発タグからVisual Basicを起動。
すると次のような画面になります。

ここから先、どうすれば？と思ったことも
ChatGPTに相談すれば答えてくれました。
・挿入タグの標準モジュールを開き、コード出てきたウインドウにコードを貼り付け

・貼り付け後ファイルを保存

・続いて実行します。

するとウィンドウが表示されるので項目を選択して実行をします。
まずは、反映ボタンを作成したかったので、ボタン作成から。

続いて、Sheet2振分数量反映も実行すると希望通りに表に数値が反映されました！

しかし、りんごだけではなく、バナナも表に反映させたいので、CodePenで作成した数値を「Sheet3」に貼り付けし、新たに加えたsheetも参照するように、新たにVBAコードの作成を依頼。

Sheet追加時も同様に処理

作成されたコードはこちら Option Explicit

'============================================================
' 同形式の振分シートをまとめて「第１・２」シートへ反映するマクロ
'
' 反映元シートの想定：
' A1：商品名
' B1：商品名の値
' A2：店舗名
' E2：振分数量
' A3以降：店舗名
' E3以降：振分数量
'
' 反映先「第１・２」シートの想定：
' G列：商品名
' 11行目：店舗名見出し
' 商品名行 × 店舗名列の交点に振分数量を反映
'============================================================

Private Const PLAN_SHEET_NAME As String = "第１・２"
Private Const PRODUCT_COL As String = "G"
Private Const STORE_HEADER_ROW As Long = 11
Private Const SRC_PRODUCT_CELL As String = "B1"
Private Const SRC_STORE_COL As String = "A"
Private Const SRC_QTY_COL As String = "E"
Private Const SRC_START_ROW As Long = 3

'------------------------------------------------------------
' 初回のみ実行：第１・２シートにボタンを作成します
'------------------------------------------------------------
Public Sub 第12シートに全Sheet反映ボタン作成()

Dim ws As Worksheet
Dim btn As Button
Dim shp As Shape

Set ws = ThisWorkbook.Worksheets(PLAN_SHEET_NAME)

'同じボタンが既にある場合は削除して作り直す
For Each shp In ws.Shapes
    If shp.Name = "btnAllDistributionReflect" Then
        shp.Delete
        Exit For
    End If
Next shp

Set btn = ws.Buttons.Add( _
    Left:=ws.Range("V1").Left, _
    Top:=ws.Range("V1").Top, _
    Width:=170, _
    Height:=34)

With btn
    .Name = "btnAllDistributionReflect"
    .Caption = "全振分Sheetを反映"
    .OnAction = "全振分Sheetを反映"
End With

MsgBox "第１・２シートにボタンを作成しました。", vbInformation

End Sub

'------------------------------------------------------------
' Sheet2、Sheet3など、振分形式のシートをすべて反映します
'------------------------------------------------------------
Public Sub 全振分Sheetを反映()

Dim wsPlan As Worksheet
Dim wsSrc As Worksheet
Dim targetSheetCount As Long
Dim updateCount As Long
Dim missingProducts As String
Dim missingStores As String
Dim skippedSheets As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False
Application.EnableEvents = False

Set wsPlan = ThisWorkbook.Worksheets(PLAN_SHEET_NAME)

For Each wsSrc In ThisWorkbook.Worksheets

    If IsDistributionSheet(wsSrc) Then
        targetSheetCount = targetSheetCount + 1

        ReflectOneDistributionSheet _
            wsPlan:=wsPlan, _
            wsSrc:=wsSrc, _
            updateCount:=updateCount, _
            missingProducts:=missingProducts, _
            missingStores:=missingStores
    Else
        If wsSrc.Name <> PLAN_SHEET_NAME Then
            skippedSheets = skippedSheets & vbCrLf & "・" & wsSrc.Name
        End If
    End If

Next wsSrc

If targetSheetCount = 0 Then
    MsgBox "反映対象の振分シートが見つかりませんでした。" & vbCrLf & _
           "A1が「商品名」、A2が「店舗名」、E2が「振分数量」のシートを対象にします。", vbExclamation
    GoTo ExitHandler
End If

Dim msg As String
msg = "反映処理が完了しました。" & vbCrLf & vbCrLf & _
      "対象シート数：" & targetSheetCount & "件" & vbCrLf & _
      "反映件数：" & updateCount & "件"

If missingProducts <> "" Then
    msg = msg & vbCrLf & vbCrLf & _
          "【第１・２シートのG列に商品名が見つからなかったもの】" & _
          missingProducts
End If

If missingStores <> "" Then
    msg = msg & vbCrLf & vbCrLf & _
          "【第１・２シートの11行目に店舗名が見つからなかったもの】" & _
          missingStores
End If

MsgBox msg, vbInformation

ExitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox "エラーが発生しました。" & vbCrLf & Err.Description, vbCritical
Resume ExitHandler

End Sub

'------------------------------------------------------------
' 1つの振分シートを第１・２シートに反映
'------------------------------------------------------------
Private Sub ReflectOneDistributionSheet( _
ByVal wsPlan As Worksheet, _
ByVal wsSrc As Worksheet, _
ByRef updateCount As Long, _
ByRef missingProducts As String, _
ByRef missingStores As String)

Dim productName As String
Dim productCell As Range
Dim storeCell As Range
Dim lastSrcRow As Long
Dim r As Long
Dim storeName As String
Dim qty As Variant

productName = Trim(CStr(wsSrc.Range(SRC_PRODUCT_CELL).Value))

If productName = "" Then Exit Sub

Set productCell = wsPlan.Columns(PRODUCT_COL).Find( _
    What:=productName, _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    MatchCase:=False)

If productCell Is Nothing Then
    missingProducts = missingProducts & vbCrLf & "・" & wsSrc.Name & "：" & productName
    Exit Sub
End If

lastSrcRow = wsSrc.Cells(wsSrc.Rows.Count, SRC_STORE_COL).End(xlUp).Row

If lastSrcRow < SRC_START_ROW Then Exit Sub

For r = SRC_START_ROW To lastSrcRow

    storeName = Trim(CStr(wsSrc.Cells(r, SRC_STORE_COL).Value))
    qty = wsSrc.Cells(r, SRC_QTY_COL).Value

    If storeName <> "" Then

        Set storeCell = wsPlan.Rows(STORE_HEADER_ROW).Find( _
            What:=storeName, _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            MatchCase:=False)

        If storeCell Is Nothing Then
            missingStores = missingStores & vbCrLf & "・" & wsSrc.Name & " / " & productName & " / " & storeName
        Else
            wsPlan.Cells(productCell.Row, storeCell.Column).Value = qty
            updateCount = updateCount + 1
        End If

    End If

Next r

End Sub

'------------------------------------------------------------
' 振分シートかどうかを自動判定
' シート名ではなく、見出しで判定するため、Sheet4以降でも対応可能
'------------------------------------------------------------
Private Function IsDistributionSheet(ByVal ws As Worksheet) As Boolean

If ws.Name = PLAN_SHEET_NAME Then
    IsDistributionSheet = False
    Exit Function
End If

If Trim(CStr(ws.Range("A1").Value)) = "商品名" _
   And Trim(CStr(ws.Range("A2").Value)) = "店舗名" _
   And Trim(CStr(ws.Range("E2").Value)) = "振分数量" Then
    IsDistributionSheet = True
Else
    IsDistributionSheet = False
End If

End Function

コードの中身を理解していないため、先ほどのコードと別でモジュール作る？先ほどのモジュールを削除する？分からなかった為、ChatGPTに確認したところ、「基本的には先ほどのコードを削除して、今回のコードで上書き」と教えてくれました。
そのとおりにすすめて、実行したら、期待通りの反映がされました！

しかし、何かおかしい、フォントが揃っていないことに違和感。

こちらも機能を追加してフォントの統一も備えることができました。

フォント統一追加コード

Public Sub 全シートフォントをMeiryoUIに統一()

Dim ws As Worksheet
Dim shp As Shape

For Each ws In ThisWorkbook.Worksheets

    'シート内のすべてのセルをMeiryo UIにする
    ws.Cells.Font.Name = FIXED_FONT_NAME

    '図形・ボタン・テキストボックスなどもMeiryo UIにする
    For Each shp In ws.Shapes
        On Error Resume Next

        If shp.TextFrame2.HasText Then
            shp.TextFrame2.TextRange.Font.Name = FIXED_FONT_NAME
        End If

        If shp.TextFrame.Characters.Count > 0 Then
            shp.TextFrame.Characters.Font.Name = FIXED_FONT_NAME
        End If

        On Error GoTo 0
    Next shp

Next ws

サンプル表はここで終了で、実際に使用している表に同じ機能を実装します。
100店舗以上の為、表の配置がサンプルとは違います。
配置をChatGPTに伝えて再度コード作成する必要がありました。

調整をすることで店舗数に合わせた運用をすることができました！

同僚に機能を説明して、使ってみてもらいました。
B😁 「なんか便利そうだね、使えそうだけど、関数でよくない？」
私😭「私も関数を普段使っているので分かりますけれど、誤って関数消してしまったりと不便なこともありますよね！」
B😁 「まあそうだなー、使ってみるよ、ありがとう」
私😊「こちらこそありがとうございます！直した方が良いところ、教えてください」
B😁 「了解」

まとめ
Bさんにまだ感想をお聞きできていないですが、自分の中ではまだまだ改善の余地があります。作成したファイルの貼り付けを簡略化する方法があると思うので、改善します。

また、全店舗を一枚にするのではなく、１店舗で１枚にまとめると、店舗担当者の方は見やすいと感じます。次回そこにも着手していきます。

最後まで読んでいただいて、ありがとうございました。