勤め先で業者ごとに商品の仕入額を月ごとに集計し、かつ週次集計もつくりたいという依頼がありました。
Excelでやる場合は月ごとにデータを分けたいところですが、そうすると週が途中で切れちゃったりといろいろ不都合。
そういうわけでExcel内にテーブルを作成し、指定の期間で自動的に集計ができるようなシステムをつくりました。
ぶっちゃけAccessでやれよって内容だと思うのですが、これぐらいの内容であればExcelで十分でしょうし、MacだとAccess使えませんしね。
プログラムの内容
プログラムの要件としては、
- 複数の拠点があり、それぞれ複数の取引相手がいる
- 仕入にかかった費用を集計したい
- 拠点・取引相手ごとの集計を、月間と週次で出したい
ってな感じです。
今回は仕入でやっていますが、売上でも機能的に問題ないはず。
個数を入力するようにつくっていますが、これは費用の計算を簡単にするためであって在庫管理は考えておりませんのであしからず。
テーブルへの登録
登録シートというのがメインのメニュー。
テーブルに登録するための入力画面、取引拠点と取引相手のマスタ、集計用のメニューがあります。
取引拠点と取引相手はサンプルということで、僕の地元・山科にある神社仏閣を並べました。
まずは日付と取引拠点、取引相手、商品名、単価、個数を入力します。商品は一度に５つまで入力できます。
入力した上で下の登録ボタンを押すと、商品名と単価と個数が消えます。これで登録完了です。
日付と取引拠点と取引相手は残るので、他にあればそのまま入力していきます。他になければ右上のリセットボタンで消えます。
登録を押した後、入力したデータは各取引拠点のシートのテーブルに登録されます。
月間の集計
各取引拠点ごとのシートがそのまま月間の集計になります。
例えば、最初は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 SubExcel形式で出力
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 SubPDF形式で出力
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
コメント