リーフノリコールデニッサンニイッタヒニカンセイシタ

Sub CreateSummarySheet()
    ' 最適化の開始
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim wsAllData As Worksheet
    Dim wsOrderFormat As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim wsNew As Worksheet
    Dim currentSheet As String
    Dim productName As String
    Dim quantity As Double ' 数量を数値として格納する
    Dim rowOffset As Long ' 行のオフセットを宣言
    Dim maxHiddenRows As Long
    Dim summaryDict As Object
    Dim key As Variant
    Dim row As Range
    Dim isEmptyRow As Boolean ' 空の行フラグ
    Dim orderSheet As Worksheet
    
    ' 全データシートとフォーマット受注シートの設定
    Set wsAllData = ThisWorkbook.Sheets("全データ")
    Set wsOrderFormat = ThisWorkbook.Sheets("フォーマット受注")
    
    ' 全データシートのデータを発送日ごとにまとめるための辞書を作成
    Set summaryDict = CreateObject("Scripting.Dictionary")
    
    ' 全データシートのデータを発送日ごとにまとめる
    lastRow = wsAllData.Cells(wsAllData.Rows.Count, "D").End(xlUp).row
    For i = 2 To lastRow
        ' 商品名と数量を取得
        productName = wsAllData.Cells(i, "E").Value
        quantity = wsAllData.Cells(i, "G").Value
        
        ' 発送日を取得してシート名として使用
        currentSheet = Format(wsAllData.Cells(i, "D").Value, "yyyymmdd")
        
        ' 商品名が辞書に存在するか確認し、数量を追加する
        If summaryDict.exists(currentSheet & "|" & productName) Then
            summaryDict(currentSheet & "|" & productName) = summaryDict(currentSheet & "|" & productName) + quantity
        Else
            summaryDict(currentSheet & "|" & productName) = quantity
        End If
    Next i
    
    ' 各日付ごとのシート内のデータを処理する
    For Each key In summaryDict.Keys
        currentSheet = Split(key, "|")(0) ' 日付を取得
        productName = Split(key, "|")(1) ' 商品名を取得
        quantity = summaryDict(key) ' 数量を取得
        
        ' 日付のシートが存在しない場合は作成
        If Not SheetExists(currentSheet & "受") Then
            Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsNew.Name = currentSheet & "受"
            ' フォーマットの内容と書式をコピー
            wsOrderFormat.Cells.Copy wsNew.Cells
            ' まとめた発送日をG3セルに入力
            wsNew.Range("G3").Value = CDate(Left(currentSheet, 4) & "/" & Mid(currentSheet, 5, 2) & "/" & Right(currentSheet, 2))
            rowOffset = 0 ' 行のオフセットをリセット
        Else
            Set wsNew = ThisWorkbook.Sheets(currentSheet & "受")
        End If
        
        ' 商品名と数量をフォーマットシートに入力
        wsNew.Range("B13").Offset(rowOffset, 0).Value = productName
        wsNew.Range("E13").Offset(rowOffset, 0).NumberFormat = "0" ' 数値として入力
        wsNew.Range("E13").Offset(rowOffset, 0).Value = quantity
        
        ' B列が空欄の行を非表示にする（ただし13行目から51行目までは非表示にしない）
        Dim lastRowB As Long
        lastRowB = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).row ' B列の最終行を取得
        Dim rowIdx As Long ' iをrowIdxに変更
        For rowIdx = 13 To lastRowB ' B列の13行目から最終行までループ
            If rowIdx < 13 Or rowIdx > 51 Then ' 13行目から51行目までは非表示にしない
                If IsEmpty(wsNew.Cells(rowIdx, "B").Value) Then ' B列のセルが空かどうかをチェック
                    wsNew.Rows(rowIdx).EntireRow.Hidden = True ' 空の場合、行を非表示にする
                Else
                    wsNew.Rows(rowIdx).EntireRow.Hidden = False ' 空でない場合、行を表示する
                End If
            End If
        Next rowIdx
        
        rowOffset = rowOffset + 1 ' 行のオフセットをインクリメント
    Next key
    
    ' 受注書の作成が完了した後、受注書を複製して発注書を作成する
    For Each orderSheet In ThisWorkbook.Sheets
        If orderSheet.Name Like "*受" Then
            Dim newSheetName As String
            newSheetName = Replace(orderSheet.Name, "受", "発")
            orderSheet.Copy After:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                .Name = newSheetName
                
                ' 発注書の特定のセルに変更を加える
                ' A1を発注書に変更
                .Range("A1").Value = "発注書"
                ' A3をXXXXXXXXXXXXXに変更
                .Range("A3").Value = "XXXXXXXXXXXXX"
                ' B8を以下の内容にて発注致します。に変更
                .Range("B8").Value = "以下の内容にて発注致します。"
                ' B7の内容を削除
                .Range("B7").ClearContents
                ' E7に全データシートのK1の内容を記入
                .Range("E7").Value = wsAllData.Range("K1").Value
            End With
        End If
    Next orderSheet
    
    ' 最適化の終了
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function

いきなりのコード。
作成中の受発注書プログラムが完成ぃ！
販売情報を集計して日付ごとの受注書と発注書を一気に作ってやろうぞ！というやつです。

さて、今日は日産へリコール対応のため行ってきました。

商品情報詳細｜リコール情報サイト｜消費者庁

これですね。。内容見たら結構怖い。。。。症状発生しなくて良かった。

明日も休みだから、ヤフオクの在庫管理について考えてみようかな。。

おやすみなさい。