With ThisWorkbook.Worksheets(1)
    .Cells(2, 1) = ブック.Worksheets(1).Range("B4").Value
    For j = 1 To 5
        .Cells(2, j + 1) = ブック.Worksheets(1).Cells(7, j).Value
    Next
End With

Option Explicit
Dim 月分シート, 作業シート
Dim 日別シート, 日別シート摘要セル範囲
Dim 末日, カウンタ, データ数, 下端行, 抽出列
Dim 結果
'-----------------------------------------------------------------------------------------
Sub 当月分集計シートから日にち別シートを作成する()
    月分シート = "7月分"                                '月分シートの名前
    日別シート摘要セル範囲 = "B13:Q19"                  '日別シートの摘要のセル範囲
    末日 = Worksheets(月分シート).Range("B4").End(xlToRight).Column - 2 'データの右端-2
    Application.ScreenUpdating = False                  '画面を更新しない
    作業用にシートを挿入する
    For カウンタ = 1 To 末日                            '1日から末日まで繰り返す
        数量が空白以外の行をフィルタしデータ部だけを作業シートへコピーする
        If データ数 <> 0 Then                           'その日のデータ数が0でなければ
            作業シートの品名と数量を日別シートへコピーする
        End If
        Worksheets(月分シート).AutoFilterMode = False   'フィルタモードを解除
    Next
    作業シートを削除する
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 作業用にシートを挿入する()
    Worksheets.Add
    作業シート = ActiveSheet.Name
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 数量が空白以外の行をフィルタしデータ部だけを作業シートへコピーする()
    Worksheets(作業シート).Cells.Clear                         '全てのセルを全てクリア
    With Worksheets(月分シート)
        .Activate
        抽出列 = 1 + カウンタ                                  'フィルタする列(1=B列)
        .Range("B4").AutoFilter Field:=抽出列, Criteria1:="<>" '空白以外を抽出
        Set 結果 = .AutoFilter.Range
        データ数 = 結果.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        If データ数 <> 0 Then                                  'データ数が0でなければ
            Set 結果 = 結果.Resize(結果.Rows.Count - 1).Offset(1) 'データ部だけに設定
            結果.Copy Destination:=Worksheets(作業シート).Range("B5") 'コピー
        End If
    End With
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 作業シートの品名と数量を日別シートへコピーする()
    日別シート = LTrim(Str(カウンタ))
    Worksheets(日別シート).Range(日別シート摘要セル範囲).ClearContents    'クリア
    下端行 = Worksheets(作業シート).Range("B" & Rows.Count).End(xlUp).Row 'データの下端
    Worksheets(作業シート).Activate
    Range(Cells(5, 1 + 抽出列), Cells(下端行, 1 + 抽出列)).Copy           '数量をコピー
    Worksheets(日別シート).Range("P13").PasteSpecial Paste:=xlPasteValues '値を貼り付け
    Range("B5:B" & 下端行).Copy                                           '品名
    Worksheets(日別シート).Range("C13").PasteSpecial Paste:=xlPasteValues
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 作業シートを削除する()
    Application.DisplayAlerts = False           '注意メッセージを表示しない
    Worksheets(作業シート).Delete
    Application.DisplayAlerts = True
End Sub