だいぶ前にこんな記事を書きました。改めて見てよくこんな内容で記事にしたなぁと少し恥ずかしい内容でした。
おそらくテーブルをVBAで操作するというのが個人的に斬新だったんでしょうね。この記事の中でも書いてますが同じことをやるならAccessでやった方がいいです。
とは言え、Accessが使える環境は限られていますし、Excelで簡単なデータベースを用意したいというのであればテーブルはとても有用です。
そこで今回はこの記事の内容を元に、今の僕ならこんな感じで作るというリマスター記事です。
元の記事ではシート上のセルに入力する形にしていましたが、フォームを活用することにしました。この方がユーザーが入力を間違えないので良いと思います。
マクロの内容
こちらがサンプルファイルです。もちろん記載されているのはダミー情報です。
シートとテーブルの構成
シート「仕入テーブル」にはテーブル「T_仕入テーブル」があります。今回のマクロの主役でして、仕入データを記録する台帳です。
金額の列は単価と数量を掛けた値が入るように計算式を入れています。
このテーブルは普段ID、支店コード、取引先コード、商品コードを非表示にしています。
これらの列の値はマクロで入力することになっており、ユーザから見えなくても問題ありません。
シート「支店マスタ」にはテーブル「T_支店マスタ」があります。
以降のテーブルも同様の仕様ですが、「非表示」の列は値を「1」にするとフォームのリストに表示されなくなります。
使わなくなったデータが表示されると邪魔になるので、不要になったらこの列の値を変えます。
シート「取引先マスタ」にはテーブル「T_取引先マスタ」があります。仕様は支店マスタとほとんど同じです。
シート「商品マスタ」にはテーブル「T_商品マスタ」があります。
T_支店マスタとT_取引マスタと違うところは単価があるぐらいです。
シートは以上です。
ボタン「登録」の動作
シート「仕入テーブル」にあるボタン「仕入登録」を押すと「仕入登録フォーム」が開きます。オブジェクトの名前は「UserForm_PurchaseReg」にしています。
日付は自動的にフォームを開いた時点の年月日が入力されます。
支店、取引先、商品名はそれぞれT_支店マスタ、T_取引先マスタ、T_商品マスタより、「ふりがな」でソートした名前がコンボボックスで選べます。「非表示」が「1」の行については表示されません。
単価は商品名を選ぶとT_商品マスタから単価を取得して自動的に入力されますが、値の変更が可能です。取引によっては値下げとかありますからね。
フォーム上のボタン「登録」を押すとフォームに入力した内容がT_仕入テーブルに登録されます。
日付、支店コード、取引先コード、商品コード、単価、数量が入力されます。
このテーブルで単価を別のテーブルからのVLOOKUPで取得していないのは、取引ごとに単価が変わったり、通常の単価も後に変わる可能性があるからです。これをVLOOKUPで取得していると変更した際に過去の取引分もすべて変わってしまいます。
フォームの方に話を戻しますと、ボタン「登録」の後は商品名、単価、数量がクリアされ、日付、支店、取引先は入力した情報がそのまま残ります。他の商品を続けて登録する場合が多いことを想定しています。
日付、支店、取引先もクリアする場合はボタン「クリア」を押します。
ボタン「出力」の動作
シート「仕入テーブル」にあるボタン「出力」を押すと、フォーム「UserForm_Export」が表示されます。
TextBox_YearとComboBox_Monthはフォームを開いて時点の年月が初期値として入り、ここで出力したい年月を入力します。
ボタン「Excel」をExcel形式で、ボタン「PDF」を押すとPDF形式で出力します。
出力先は当マクロ実行ブックと同じフォルダ内に「yyyy年m月」のファイル名で保存されます。
出力される内容は、まずは年月でフィルターをかけた全データのシートである「yyyy年m月全データ」です。
その全データのシートをソースとした、支店と取引先ごとのピボットテーブルが表示されているシート「集計」が作成されます。
あとは支店ごとにシートが作成されます。データが存在しない場合は作成はスキップされます。
PDFでも上記と同じ内容のものが出力されます。
流れとしては、新しいブックを作成してT_仕入テーブルを元に上記のシートを作成。Excelの場合はそのブックを保存し、PDFの場合はブックをPDFで出力したあとに保存せずに閉じています。
VBA
Module1
Public Const PURCHASE_SHEETNAME As String = "仕入テーブル"
Public Const PURCHASE_LISTNAME As String = "T_仕入テーブル"
Public Const BRANCH_SHEETNAME As String = "支店マスタ"
Public Const BRANCH_LISTNAME As String = "T_支店マスタ"
Public Const BRANCHCODE_COLNAME As String = "支店コード"
Public Const BRANCHNAME_COLNAME As String = "支店名"
Public Const INVISIBLE_COLNAME As String = "非表示"
Public Const DATE_COLNAME As String = "日付"
Sub 仕入登録フォームOPEN()
UserForm_PurchaseReg.StartUpPosition = 3
UserForm_PurchaseReg.Show vbModeless
End Sub
Sub 出力フォームOPEN()
UserForm_Export.StartUpPosition = 2
UserForm_Export.Show
End Sub標準モジュールには、以降のコードで共通して且つ繰り返し使う値について定数の宣言を行います。
そしてボタン「登録」「出力」を押した際にフォームを開くためのコードを記述しています。
UserForm_PurchaseReg
フォーム「UserForm_PurchaseReg」内にまとめて記述しているコードですが、そのままだとわかりづらいので機能ごとにある程度分割しました。
グローバル変数もありますので、実際には１つの場所に記述していると考えてください。
フォームの初期化
Private Sub UserForm_Initialize()
Dim tbl As ListObject 'テーブル
Dim rng As Range 'テーブルの範囲
Dim i As Integer 'カウンタ
'支店名セット
Set tbl = Worksheets(BRANCH_SHEETNAME).ListObjects(BRANCH_LISTNAME)
With tbl
'フィルターを解除する
.ShowAutoFilter = False
'テーブルを「ふりがな」でソートする
.Range.Sort key1:=.ListColumns("ふりがな").Range, order1:=xlAscending, Header:=xlYes
'非表示列「0」でフィルター
.Range.AutoFilter .ListColumns(INVISIBLE_COLNAME).Index, "0"
'支店名をコンボボックスに格納
On Error Resume Next
Set rng = .ListColumns(BRANCHNAME_COLNAME).DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
Me.ComboBox_Branch.Clear
If Not rng Is Nothing Then
For Each cell In rng
Me.ComboBox_Branch.AddItem cell.Value
Next cell
End If
Set rng = Nothing
'支店コードを配列に格納
On Error Resume Next
Set rng = .ListColumns(BRANCHCODE_COLNAME).DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
i = 0
If Not rng Is Nothing Then
For Each cell In rng
ReDim Preserve ARR_BRANCH_CODE(i)
ARR_BRANCH_CODE(i) = cell.Value
i = i + 1
Next cell
End If
'支店コードでソート
.Range.Sort key1:=.ListColumns("支店コード").Range, order1:=xlAscending, Header:=xlYes
'フィルターを解除する
.ShowAutoFilter = False
End With
'オブジェクトを解放する
Set tbl = Nothing
Set rng = Nothing
'取引先セット
Set tbl = Worksheets("取引先マスタ").ListObjects("T_取引先マスタ")
With tbl
'フィルターを解除する
.ShowAutoFilter = False
'テーブルを「ふりがな」でソートする
.Range.Sort key1:=.ListColumns("ふりがな").Range, order1:=xlAscending, Header:=xlYes
'非表示列「0」でフィルター
.Range.AutoFilter .ListColumns(INVISIBLE_COLNAME).Index, "0"
'取引先名をコンボボックスに格納
On Error Resume Next
Set rng = .ListColumns("取引先名").DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
Me.ComboBox_Partner.Clear
If Not rng Is Nothing Then
For Each cell In rng
Me.ComboBox_Partner.AddItem cell.Value
Next cell
End If
'取引先コードを配列に格納
On Error Resume Next
Set rng = .ListColumns("取引先コード").DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
i = 0
If Not rng Is Nothing Then
For Each cell In rng
ReDim Preserve ARR_PARTNER_CODE(i)
ARR_PARTNER_CODE(i) = cell.Value
i = i + 1
Next cell
End If
'取引先コードでソート
.Range.Sort key1:=.ListColumns("取引先コード").Range, order1:=xlAscending, Header:=xlYes
'フィルターを解除する
.ShowAutoFilter = False
End With
'オブジェクトを解放する
Set tbl = Nothing
Set rng = Nothing
'商品名セット
Set tbl = Worksheets("商品マスタ").ListObjects("T_商品マスタ")
With tbl
'フィルターを解除する
.ShowAutoFilter = False
'テーブルを「ふりがな」でソートする
.Range.Sort key1:=.ListColumns("ふりがな").Range, order1:=xlAscending, Header:=xlYes
'非表示列「0」でフィルター
.Range.AutoFilter .ListColumns(INVISIBLE_COLNAME).Index, "0"
'商品名をコンボボックスに格納
On Error Resume Next
Set rng = .ListColumns("商品名").DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
Me.ComboBox_ItemName.Clear
If Not rng Is Nothing Then
For Each cell In rng
Me.ComboBox_ItemName.AddItem cell.Value
Next cell
End If
'商品コードを配列に格納
On Error Resume Next
Set rng = .ListColumns("商品コード").DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
i = 0
If Not rng Is Nothing Then
For Each cell In rng
ReDim Preserve ARR_ITEM_CODE(i)
ARR_ITEM_CODE(i) = cell.Value
i = i + 1
Next cell
End If
'単価を配列に格納
On Error Resume Next
Set rng = .ListColumns("単価").DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
On Error GoTo 0
i = 0
If Not rng Is Nothing Then
For Each cell In rng
ReDim Preserve ARR_UNIT_PRICE(i)
ARR_UNIT_PRICE(i) = cell.Value
i = i + 1
Next cell
End If
'商品コードでソート
.Range.Sort key1:=.ListColumns("商品コード").Range, order1:=xlAscending, Header:=xlYes
'フィルターを解除する
.ShowAutoFilter = False
End With
'フォームの入力をすべてクリア
Call 全クリア
End Sub
フォームにあるコンボボックスにテーブルの列の値を入れていきます。
テーブルの列は番号ではなく見出し名で指定します。こうすれば列の順番が変わってもコードを変更する必要はありません。
列の範囲を取得する際、データがないとエラーになってしまいますので、そこはOn Error Resume Nextで回避するようにしています。
フォーム上の各オブジェクトの値をクリア
Private Sub CommandButton_Clear_Click()
'すべての入力をクリアする
Call 全クリア
End Sub
Private Sub 全クリア()
'フォームの入力をすべてクリア
TextBox_RegisterDate = Date
ComboBox_Branch.ListIndex = -1
ComboBox_Partner.ListIndex = -1
Call 商品クリア
End Sub
Private Sub 商品クリア()
'フォームの商品、単価、数量、金額をクリア
ComboBox_ItemName.ListIndex = -1
TextBox_UnitPrice.Value = 0
TextBox_Quantity = 1
Label_Amount.Caption = 0
End Subフォームの入力クリアは外でも使うのでプロシージャを分けて使いまわします。
フォーム上の各オブジェクトの変更時
Private Sub ComboBox_ItemName_Change()
Dim targetIndex As Variant '選択したコンボボックスの番号
'選択した商品の単価をテキストボックスに入力
targetIndex = Me.ComboBox_ItemName.ListIndex
If targetIndex > -1 Then
TextBox_UnitPrice.Value = ARR_UNIT_PRICE(targetIndex)
End If
End Sub
Private Sub TextBox_UnitPrice_Change()
'単価が変更されたら金額を更新
Call 金額計算
End Sub
Private Sub TextBox_Quantity_Change()
'個数が変更されたら金額を更新
Call 金額計算
End Sub
Private Sub 金額計算()
'金額を計算
If TextBox_UnitPrice.Value <> "" And TextBox_Quantity.Value <> "" Then
Label_Amount.Caption = TextBox_UnitPrice.Value * TextBox_Quantity
End If
End Sub商品を選択したら単価をテーブルから取得してテキストボックスに入力、単価または数量が変更されたら金額を計算して変更するという流れです。
単価と数量の入力を半角数字に限定する
Private Sub TextBox_UnitPrice_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'単価の入力を半角数字のみに制限する
If Not Chr(KeyAscii) Like "[0-9]" Then
KeyAscii = 0
End If
End Sub
Private Sub TextBox_Quantity_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'数量の入力を半角数字のみに制限する
If Not Chr(KeyAscii) Like "[0-9]" Then
KeyAscii = 0
End If
End Sub単価と数量に数字以外の値が入るとエラーになってしまうので制限します。
登録ボタン押下時
Private Sub CommandButton_Register_Click()
Dim tbl As ListObject 'テーブル
Dim lastRow As Long '最終行
Dim targetCol As ListColumn '対象列
'T_仕入テーブルを取得
Set tbl = Worksheets(PURCHASE_SHEETNAME).ListObjects(PURCHASE_LISTNAME)
'日付の入力を確認
If Me.TextBox_RegisterDate.Value = "" Then
MsgBox "日付が入力されていません。"
Exit Sub
End If
'西暦以外の文字列が入力されたら処理を中止する
If IsDate(Me.TextBox_RegisterDate.Value) = False Then
MsgBox "日付に日付以外の文字列が入力されています。"
Exit Sub
End If
'支店の入力を確認
If Me.ComboBox_Branch.ListIndex = -1 Then
MsgBox "支店が選択されていません。"
Exit Sub
End If
'取引先の入力を確認
If Me.ComboBox_Partner.ListIndex = -1 Then
MsgBox "取引先が選択されていません。"
Exit Sub
End If
'商品の入力を確認
If Me.ComboBox_ItemName.ListIndex = -1 Then
MsgBox "商品が選択されていません。"
Exit Sub
End If
'T_仕入テーブルにフォーム上の情報を入力
With tbl
.ShowAutoFilter = False 'フィルターを解除
.Range.Sort key1:=.ListColumns("ID").Range, order1:=xlAscending, Header:=xlYes 'ID順にソート
.ListRows.Add '行追加
lastRow = .DataBodyRange.Rows.Count '最終行を取得
'IDを入力
Set targetCol = .ListColumns("ID")
If lastRow > 1 Then
targetCol.DataBodyRange(lastRow, 1).Value = targetCol.DataBodyRange(lastRow - 1, 1).Value + 1
Else
targetCol.DataBodyRange(lastRow, 1).Value = 1
End If
'日付を入力
Set targetCol = .ListColumns(DATE_COLNAME)
targetCol.DataBodyRange(lastRow, 1).Value = Me.TextBox_RegisterDate.Value
'支店コードを入力
Set targetCol = .ListColumns(BRANCHCODE_COLNAME)
targetCol.DataBodyRange(lastRow, 1).Value = ARR_BRANCH_CODE(Me.ComboBox_Branch.ListIndex)
'取引先コードを入力
Set targetCol = .ListColumns("取引先コード")
targetCol.DataBodyRange(lastRow, 1).Value = ARR_PARTNER_CODE(Me.ComboBox_Partner.ListIndex)
'商品コードを入力
Set targetCol = .ListColumns("商品コード")
targetCol.DataBodyRange(lastRow, 1).Value = ARR_ITEM_CODE(Me.ComboBox_ItemName.ListIndex)
'単価を入力
Set targetCol = .ListColumns("単価")
targetCol.DataBodyRange(lastRow, 1).Value = Me.TextBox_UnitPrice.Value
'個数を入力
Set targetCol = .ListColumns("数量")
targetCol.DataBodyRange(lastRow, 1).Value = Me.TextBox_Quantity.Value
End With
'フォームの商品、単価、数量、金額をクリア
Call 商品クリア
End Subテーブルに１行追加してフォーム上の値を入力していきます。テーブルだと最終行取得のコードがシンプルで良いですね。
IDについては１行上の値に+1するという形でやってます。
UserForm_Export
年月を指定してExcelまたはPDF形式で出力するフォームです。
こちらも１つの場所に記述していますが機能で分けています。というかほとんど集計部分です。
フォームの初期化
Private Sub UserForm_Initialize()
Dim i As Integer 'カウンタ
'テキストボックスに現在の西暦を入力する
Me.TextBox_Year.Value = Year(Date)
'コンボボックスに1～12の数値を入力する
For i = 1 To 12
Me.ComboBox_Month.AddItem i
Next i
'コンボボックスに現在の月を入力する
Me.ComboBox_Month.Value = Month(Date)
End Sub月のコンボボックスには1～12のリストを入れ、それぞれフォームを開いた時の年月を入力します。
年の入力を半角数字のみに制限する
Private Sub TextBox_Year_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'年の入力を半角数字のみに制限する
If Not Chr(KeyAscii) Like "[0-9]" Then
KeyAscii = 0
End If
End Sub出力
Dim EXPORT_WORKBOOK As Workbook '出力用Excelブック
Dim YEAR_MONTH As String 'yyyy年m月
Dim IS_ERROR As Boolean 'エラー判定用
Private Sub CommandButton_ExportExcel_Click()
Dim exportFilePath As String '出力ファイル名
'エラー判定用フラグの初期値
IS_ERROR = False
'集計用のブックを作成
Call 集計
'エラーの場合は処理を中止
If IS_ERROR = True Then
Exit Sub
End If
'ファイル名をマクロ実行ブックのあるフォルダ内のyyyy年m月.xlsxにする
exportFilePath = ThisWorkbook.Path & "\" & YEAR_MONTH & ".xlsx"
'集計用ブックを保存する
With EXPORT_WORKBOOK
.SaveAs fileName:=exportFilePath
.Close
End With
MsgBox "出力完了しました。" & vbcelf & vbCrLf & exportFilePath
End Sub
Private Sub CommandButton_ExportPDF_Click()
Dim exportFilePath As String '出力ファイル名
'エラー判定用フラグの初期値
IS_ERROR = False
'集計用のブックを作成
Call 集計
'エラーの場合は処理を中止
If IS_ERROR = True Then
Exit Sub
End If
'ファイル名をマクロ実行ブックのあるフォルダ内のyyyy年m月.pdfにする
exportFilePath = ThisWorkbook.Path & "\" & YEAR_MONTH & ".pdf"
'集計用ブックをPDF出力し、保存せずに閉じる
With EXPORT_WORKBOOK
.ExportAsFixedFormat Type:=xlTypePDF, fileName:=exportFilePath
.Close SaveChanges:=False
End With
MsgBox "出力完了しました。" & vbcelf & vbCrLf & exportFilePath
End Sub
Private Sub 集計()
Dim subtotalSheetName As String '集計シート名
Dim arrBranch() As Variant '支店を格納する配列
Dim tbl As ListObject 'テーブル
Dim rng As Range 'テーブルのデータ範囲
Dim rngHeaders As Range 'テーブルのヘッダー行
Dim rngTotalRow As Range 'テーブルの集計行
Dim i As Integer 'カウンタ
Dim yearFilter As Integer 'フォーム上で入力された年
Dim monthFileter As Integer 'フォーム上で入力された月
Dim wsDest As Worksheet 'シート
Dim pc As PivotCache 'ピボットキャッシュ
Dim pt As PivotTable 'ピボットテーブル
'西暦以外の文字列が入力されたら処理を中止する
If IsDate(Me.TextBox_Year.Value & "/4/1") = False Then
MsgBox "西暦以外の文字列が入力されました。処理を中止します。"
IS_ERROR = True
Exit Sub
End If
'フォーム上で入力された年と月を取得する
yearFilter = Val(Me.TextBox_Year.Value)
monthFilter = Val(Me.ComboBox_Month.Value)
'yyyy年m月にする
YEAR_MONTH = yearFilter & "年" & monthFilter & "月"
'支店マスタの情報を取得
With Worksheets(BRANCH_SHEETNAME).ListObjects(BRANCH_LISTNAME)
'非表示列「0」でフィルター
.ShowAutoFilter = False
.Range.AutoFilter .ListColumns(INVISIBLE_COLNAME).Index, "0"
'支店コードを配列に格納
Set rng = .ListColumns(BRANCHCODE_COLNAME).DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
i = 0
For Each cell In rng
ReDim Preserve arrBranch(1, i)
arrBranch(0, i) = cell.Value
i = i + 1
Next cell
'支店名を配列に格納
Set rng = .ListColumns(BRANCHNAME_COLNAME).DataBodyRange.SpecialCells(Type:=xlCellTypeVisible)
i = 0
For Each cell In rng
arrBranch(1, i) = cell.Value
i = i + 1
Next cell
End With
'仕分テーブルを取得
Set tbl = ThisWorkbook.Worksheets(PURCHASE_SHEETNAME).ListObjects(PURCHASE_LISTNAME)
'仕分テーブルのヘッダー行を取得
Set rngHeaders = tbl.HeaderRowRange
'新規でペースト先となるExcelブックを開く
Application.SheetsInNewWorkbook = 1
Set EXPORT_WORKBOOK = Workbooks.Add
'対象年月全体の表を転記する
tbl.ShowAutoFilter = False
tbl.Range.AutoFilter tbl.ListColumns(DATE_COLNAME).Index, _
Criteria1:=">=" & DateSerial(yearFilter, monthFilter, 1), _
Criteria2:="<" & DateSerial(yearFilter, monthFilter + 1, 1)
'見えているデータ範囲を取得する
On Error Resume Next
Set rng = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'集計行を取得する
Set rngTotalRow = tbl.TotalsRowRange
'全データを転記する
With EXPORT_WORKBOOK.ActiveSheet
'シート名
subtotalSheetName = YEAR_MONTH & "全データ"
.Name = subtotalSheetName
'見出し行
rngHeaders.Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
.Range("A2").PasteSpecial Paste:=xlPasteFormats
'データ
rng.Copy
.Range("A3").PasteSpecial Paste:=xlPasteValues
.Range("A3").PasteSpecial Paste:=xlPasteFormats
'集計行を入力する前にピボットテーブル用の範囲を取得
Set rng = .Range("A2").CurrentRegion
'集計行
rngTotalRow.Copy
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteFormats
'列幅を自動調整
.Columns.AutoFit
'A1セルに「yyyy年m月@全社」と入力し選択する
.Range("A1").Value = YEAR_MONTH & "@全社"
.Range("A1").Select
'印刷範囲の設定
With .PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End With
'カット・コピーモードを解除する
Application.CutCopyMode = False
Else
'データがない場合は処理中止
MsgBox "データがありません。処理を中止します。"
Exit Sub
End If
'全データからピボットテーブルを作成する
With EXPORT_WORKBOOK
'シートを作成する
.Worksheets.Add after:=Sheets(.Sheets.Count)
Set wsDest = .ActiveSheet
'シート名を「集計」にし、A1に「yyyy年m月集計」と入力する
With wsDest
.Name = "集計"
.Range("A1").Value = YEAR_MONTH & "集計"
End With
'ピボットキャッシュを作成
Set pc = .PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng)
End With
'ピボットテーブルを作成
Set pt = pc.CreatePivotTable(TableDestination:=wsDest.Range("A2"), TableName:="PT_集計")
'フィールドを設定
With pt
.PivotFields("取引先").Orientation = xlRowField '行を取引先にする
.PivotFields("支店名").Orientation = xlColumnField '列を支店名にする
.PivotFields("金額").Orientation = xlDataField '値を金額にする
.DataBodyRange.NumberFormat = "#,#" '値の書式をカンマ区切りにする
End With
'ピボットテーブルの更新
pt.RefreshTable
'印刷範囲の設定
With wsDest.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'支店ごとにフィルターをかけて転記する
For i = 0 To UBound(arrBranch, 2)
'rngをクリアする
Set rng = Nothing
'テーブルを対象年月、対象支社でフィルターをかける
tbl.ShowAutoFilter = False
tbl.Range.AutoFilter tbl.ListColumns(DATE_COLNAME).Index, _
Criteria1:=">=" & DateSerial(yearFilter, monthFilter, 1), _
Criteria2:="<" & DateSerial(yearFilter, monthFilter + 1, 1)
tbl.Range.AutoFilter tbl.ListColumns(BRANCHCODE_COLNAME).Index, arrBranch(0, i)
'見えているデータ範囲を取得する
On Error Resume Next
Set rng = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'データがあればシートを作成し転記
If Not rng Is Nothing Then
'仕分テーブルの集計行を取得
Set rngTotalRow = tbl.TotalsRowRange
'各支社のデータを転記する
With EXPORT_WORKBOOK
.Worksheets.Add after:=Sheets(.Sheets.Count)
With .ActiveSheet
'シート名
.Name = arrBranch(1, i)
'見出し行
rngHeaders.Copy
.Range("A2").PasteSpecial Paste:=xlPasteValues
.Range("A2").PasteSpecial Paste:=xlPasteFormats
'データ
rng.Copy
.Range("A3").PasteSpecial Paste:=xlPasteValues
.Range("A3").PasteSpecial Paste:=xlPasteFormats
'集計行
rngTotalRow.Copy
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteFormats
'列幅を自動調整する
.Columns.AutoFit
'A1に「yyyy年m月@支社」と入力し選択する
.Range("A1").Value = YEAR_MONTH & "@" & arrBranch(1, i)
.Range("A1").Select
'印刷範囲の設定
With .PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End With
'カット・コピーモードを解除する
Application.CutCopyMode = False
End With
End If
Next i
'全データのシートをアクティブにする
EXPORT_WORKBOOK.Sheets(1).Select
'元のテーブルのフィルターを解除する
tbl.ShowAutoFilter = False
End Sub新しいブックに集計する部分は共通なので、出力部分だけ分けています。
テーブルをソート、フィルターして取得する部分は仕入登録と同じテクニック。この中ではピボットテーブルを作成しているところが特筆すべき点です。
コメント