【Excel VBA】週次集計と月間集計を作成する仕入・売上表

2021.01.01

勤め先で業者ごとに商品の仕入額を月ごとに集計し、かつ週次集計もつくりたいという依頼がありました。

Excelでやる場合は月ごとにデータを分けたいところですが、そうすると週が途中で切れちゃったりといろいろ不都合。

そういうわけでExcel内にテーブルを作成し、指定の期間で自動的に集計ができるようなシステムをつくりました。

ぶっちゃけAccessでやれよって内容だと思うのですが、これぐらいの内容であればExcelで十分でしょうし、MacだとAccess使えませんしね。

スポンサーリンク

プログラムの内容

サンプルのデータです。

https://storage.iehohs.com/excel-totalization-table.zip
storage.iehohs.com

プログラムの要件としては、

  • 複数の拠点があり、それぞれ複数の取引相手がいる
  • 仕入にかかった費用を集計したい
  • 拠点・取引相手ごとの集計を、月間と週次で出したい

ってな感じです。

今回は仕入でやっていますが、売上でも機能的に問題ないはず。

個数を入力するようにつくっていますが、これは費用の計算を簡単にするためであって在庫管理は考えておりませんのであしからず。

テーブルへの登録

登録シートというのがメインのメニュー。

テーブルに登録するための入力画面、取引拠点と取引相手のマスタ、集計用のメニューがあります。

取引拠点と取引相手はサンプルということで、僕の地元・山科にある神社仏閣を並べました。

まずは日付と取引拠点、取引相手、商品名、単価、個数を入力します。商品は一度に５つまで入力できます。

入力した上で下の登録ボタンを押すと、商品名と単価と個数が消えます。これで登録完了です。

日付と取引拠点と取引相手は残るので、他にあればそのまま入力していきます。他になければ右上のリセットボタンで消えます。

登録を押した後、入力したデータは各取引拠点のシートのテーブルに登録されます。

月間の集計

各取引拠点ごとのシートがそのまま月間の集計になります。

例えば、最初は2020年12月21日のデータを登録しましたが、今度は2020年11月21日で登録してみます。

おそらくこの時点では取引拠点のシートを見ても登録したデータは表示されないと思います。

そこで、集計期間を2020年11月にして、集計ボタンを押してください。

これで各取引拠点のシートに2020年11月のデータが表示されるようになりました。

集計ボタンは、各取引拠点のシートのテーブルに指定した月でフィルタをかけるというマクロを登録しています。

つまり集計というよりも絞り込んでるだけですね。フィルタを解除したら全レコードが表示されます。

週次集計

集計の下にある週次集計の起算日を入力すると、そこから１週間分の集計が週次集計シートに表示されます。

ここはただの埋め込み関数です。マクロよりもこっちの方が良いと思います。

=SUMIFS(毘沙門堂[計], 毘沙門堂[取引相手], [@取引相手], 毘沙門堂[日付], ">=" & 登録シート!$C$19, 毘沙門堂[日付], "<=" & 登録シート!$C$20)

各取引拠点のテーブルの名前は取引拠点名で設定しています。２列目の取引相手であり、週次集計の起案日から終算日までであれば集計するというものです。

Excel形式で出力

Excelボタンを押すと、月間集計であればその月の取引拠点ごとのシートをまとめたExcelデータ、週次集計であれば起算日から１週間分のデータを表示したExcelデータを保存します。

保存先はこのマクロを動かしているブックと同じディレクトリです。

プログラムの中身的なことを言いますと、新規ブックを作成してコピペするだけです。

週次集計についてはコピペすると埋め込んでいた関数を移して元のブックとリンクになるため運用上あまりよろしくありません。コピペした後に値で貼り付け直しています。

あくまでバックアップや加工する用途なので、印刷範囲の設定はしていません。

PDF形式で出力

PDFボタンを押すとPDFで出力することも可能です。

週次集計のサイズがイマイチですが、ここは印刷範囲の設定に依存します。列の横幅とかを調整すればもう少しマシになるかな。

プログラミング

そういうわけでVBAのコードです。

すべてのコードを１つのモジュールにまとめていますが、ここではそれぞれ関連するプロシージャごとに分けています。

テーブルへの登録

Sub 登録()
    Dim hiduke As Date
    Dim kyoten As String
    Dim aite As String
    If Cells(2, 3).Value <> "" And Cells(3, 3).Value <> "" And Cells(4, 3).Value <> "" Then
        hiduke = Cells(2, 3).Value
        kyoten = Cells(3, 3).Value
        aite = Cells(4, 3).Value
    Else
        MsgBox "日付、取引拠点、取引相手に空欄があります。"
        Exit Sub
    End If
    i = 3
    rowEnd = i
    With Worksheets(kyoten)
        Do While .Cells(i, 2).Value <> ""
            i = i + 1
            rowEnd = i
        Loop
        i = 7
        Do While Cells(i, 2).Value <> ""
            .Cells(rowEnd - 1, 2).ListObject.ListRows.Add
            .Cells(rowEnd, 2).Value = hiduke                '日付
            .Cells(rowEnd, 3).Value = aite                  '取引相手
            .Cells(rowEnd, 4).Value = Cells(i, 2).Value     '商品名
            .Cells(rowEnd, 5).Value = Cells(i, 3).Value     '単価
            .Cells(rowEnd, 6).Value = Cells(i, 4).Value     '個数
            i = i + 1
            rowEnd = rowEnd + 1
        Loop
    End With
    Worksheets(kyoten).PageSetup.PrintArea = Range(Cells(2, 2), Cells(rowEnd, 7)).Address
    Call クリア
    Cells(7, 2).Select
End Sub
Sub クリア()
    Range(Cells(7, 2), Cells(11, 4)).ClearContents
End Sub
Sub リセット()
    Range(Cells(2, 3), Cells(4, 3)).ClearContents
    Call クリア
End Sub

月次集計用にフィルタをかける

Sub 集計フィルタ()
    Dim startKikan As Date
    Dim endKikan As Date
    Dim nen As Integer
    Dim tsuki As Integer
    Dim nichi As Integer
    Dim arrCnt As Integer
    Dim kyotenArr() As String
    Dim rowEnd As Long
    If Cells(15, 3).Value <> "" Then
        startKikan = Cells(15, 3).Value
    Else
        MsgBox "集計期間が入力されていません。"
        Exit Sub
    End If
    nen = Year(startKikan)
    tsuki = Month(startKikan)
    Select Case tsuki
        Case 4, 6, 9, 11
            nichi = 30
        Case 2
            If Not nen Mod 400 = 0 Then
                If nen Mod 100 = 0 Then
                    nichi = 28
                ElseIf nen Mod 4 = 0 Then
                    nichi = 29
                Else
                    nichi = 28
                End If
            Else
                nichi = 29
            End If
        Case Else
            nichi = 31
    End Select
    endKikan = nen & "/" & tsuki & "/" & nichi
    i = 3
    arrCnt = 0
    Do While Cells(i, 7).Value <> ""
        ReDim Preserve kyotenArr(arrCnt)
        kyotenArr(arrCnt) = Cells(i, 7).Value
        arrCnt = arrCnt + 1
        i = i + 1
    Loop
    For i = 0 To UBound(kyotenArr())
        Call 日付順にソート(kyotenArr(i))
        With Worksheets(kyotenArr(i))
            .Cells(2, 7).Value = startKikan
            .Range("B3").AutoFilter field:=1, _
                Criteria1:=">=" & startKikan, _
                Operator:=xlAnd, _
                Criteria2:="<=" & endKikan
        End With
    Next i
End Sub
Sub 日付順にソート(ws As String)
    Dim rowEnd As Long
    Dim n As Integer
    With Worksheets(ws)
        n = 3
        rowEnd = j
        Do While .Cells(n, 2) <> ""
            rowEnd = n
            n = n + 1
        Loop
        If rowEnd <> 3 Then
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=.Cells(3, 2), Order:=xlAscending
            .Sort.SetRange .Range(.Cells(3, 2), .Cells(rowEnd, 7))
            .Sort.Header = xlYes
            .Sort.Apply
        End If
    End With
End Sub

Excel形式で出力

Sub 集計Excel出力()
    Call 集計フィルタ
    Dim ws() As String
    Dim kikan As String
    kikan = Replace(Cells(15, 3).Value, "/", "")
    kikan = Left(kikan, 6)
    i = 3
    arrCnt = 0
    Do While Cells(i, 7).Value <> ""
        ReDim Preserve ws(arrCnt)
        ws(arrCnt) = Cells(i, 7)
        arrCnt = arrCnt + 1
        i = i + 1
    Loop
    Application.SheetsInNewWorkbook = 1
    Workbooks.Add
    Columns(1).ColumnWidth = 3
    Range(Columns(2), Columns(7)).ColumnWidth = 18
    Columns(6).ColumnWidth = 8
    For i = 0 To UBound(ws)
        With ThisWorkbook.Worksheets(ws(i))
            Worksheets(1).Copy After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = ws(i)
            .Cells(3, 2).CurrentRegion.Copy Destination:=Cells(1, 2)
            Range(Cells(1, 2), Cells(2, 7)).ClearContents
            Cells(3, 2).Select
            ActiveSheet.ListObjects.Add
            .Range(.Cells(2, 2), .Cells(2, 7)).Copy Destination:=Range(Cells(2, 2), Cells(2, 7))
        End With
    Next i
    Application.DisplayAlerts = False
    Worksheets("Sheet1").Delete
    Application.DisplayAlerts = True
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\集計_" & kikan & ".xlsx"
    MsgBox "出力完了。"
End Sub
Sub 週次集計Excel出力()
    Dim ws As String
    Dim kikan As String
    ws = "週次集計"
    kikan = Replace(Cells(19, 3).Value & "-" & Cells(20, 3).Value, "/", "")
    Application.SheetsInNewWorkbook = 1
    Workbooks.Add
    Columns(1).ColumnWidth = 3
    Range(Columns(2), Columns(9)).ColumnWidth = 18
    With ThisWorkbook.Worksheets(ws)
        ActiveSheet.Name = ws
        .Cells(3, 2).CurrentRegion.Copy Destination:=Cells(1, 2)
        Cells(1, 2).ClearContents
        Cells(4, 3).Select
        rowEnd = Selection.End(xlDown).Row - 1
        colEnd = Selection.End(xlToRight).Column
        Range(Cells(4, 3), Cells(rowEnd, colEnd)).Copy
        Range(Cells(4, 3), Cells(rowEnd, colEnd)).PasteSpecial Paste:=xlPasteValues
    End With
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\週次集計_" & kikan & ".xlsx"
    MsgBox "出力完了。"
End Sub

PDF形式で出力

Sub 集計PDF出力()
    Call 集計フィルタ
    Dim ws() As String
    Dim kikan As String
    kikan = Replace(Cells(15, 3).Value, "/", "")
    kikan = Left(kikan, 6)
    i = 3
    arrCnt = 0
    Do While Cells(i, 7).Value <> ""
        ReDim Preserve ws(arrCnt)
        ws(arrCnt) = Cells(i, 7)
        arrCnt = arrCnt + 1
        i = i + 1
    Loop
    Worksheets(ws).Select
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\月間集計_" & kikan
    Worksheets("登録シート").Select
    MsgBox "出力完了。"
End Sub
Sub 週次集計PDF出力()
    Dim ws As String
    Dim kikan As String
    ws = "週次集計"
    kikan = Replace(Cells(19, 3).Value & "-" & Cells(20, 3).Value, "/", "")
    Worksheets(ws).Select
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\週次集計_" & kikan
    Worksheets("登録シート").Select
    MsgBox "出力完了。"
End Sub

コメント

コメントする前にお読みください

プログラミングに関する質問について、詳細なコードはお答えしませんのでご了承ください。
また、迷惑コメント防止のために初回のコメント投稿は承認制です。投稿が反映されるまで少し時間がかかります。