帳票シート
A1セルから配置する必要は無く、実際に合わせてコードに対して定数で指定します。
おまけで列方向のオートフィルタ的機能で用いるスピンボタン(フォームコントロールの)を設けます。
1 | ||||
---|---|---|---|---|
key | 見出し2 | 見出し3 | 見出し4 | 見出し5 |
表示レベル | 1 | 1 | 1 | 2 |
1 | 11 | 12 | 13 | 14 |
2 | 21 | 22 | 23 | 24 |
3 | 31 | 32 | 33 | 34 |
詳細シート
フォームをデザインする様に、見出しの文字列を任意に二次元的に配置します。その右隣のセルにデータを転記します。セルは縦横連結しても大丈夫です(たぶん)。
キー値が入るセルは、書き戻し・新規追加用に、コードに対して指定してやる必要があります。
「書込」ボタンと「クリア」ボタンを設け、対応するマクロを登録します。
key | 2 | 見出し7 | 26 | ||
見出し2 | 21 | 見出し8 | 27 | ||
見出し3 | 22 | 見出し10 | 29 | ||
見出し5 | 24 | 見出し9 | 28 | ||
見出し6 | 25 | ||||
見出し4 | 23 |
対照表シート
このシートはA1セルからの固定とします。
「更新」ボタンを設け、対応するマクロを登録します。
見出し | 列No | アドレス | |
---|---|---|---|
key | 1 | $B$4 | |
見出し2 | 2 | $B$5 | |
見出し3 | 3 | $B$6 | |
見出し4 | 4 | $B$9 |
'☆標準モジュール
'===========================================================
'
' Accessの帳票(データシート)、詳細フォームの様な機能をExcelで実現する
'
' 帳票シート:Access同様のイメージ、データは下方向に積み上がっていく
' 詳細シート:帳票シートと一致するフィールド名文字列を二次元方向に配置したもの
' データはフィールド名文字列の右横セルに収納。書込、クリアボタンを設ける。
' 対照表 :帳票シートの列と、詳細シートの対応するセルアドレスの対照表
' 対照表は1行目を見だし文字列(固定)とし、二行目以降に記載。
' 詳細シートの文字列と帳票シートを照合し、対照表の自動生成機能をもつ。更新ボタンを設ける。
'
'===========================================================
'ワークシート等のオブジェクト変数を保持するクラス
'Public宣言しないとシートモジュールから参照できない
Public comSet As comSetClass
'===========================================================
'ブックオープン時自動起動マクロ
'シート保護を制御
'詳細シートはコメントアウトしていますが、立派な様式が出来たら保護しましょう
Private Sub Auto_Open()
If comSet Is Nothing Then makeComSet
With comSet
'スピンボタンにリンクするセルdspLevelのロック解除要
.dataSheet.Unprotect
.refTableSheet.Unprotect
' .detailSheet.Unprotect
'Tableとして書式設定しても有効な様です
.dataSheet.EnableAutoFilter = True
.dataSheet.Protect UserInterfaceOnly:=True, AllowSorting:=True, AllowFiltering:=True
.refTableSheet.Protect UserInterfaceOnly:=True
' .detailSheet.Protect UserInterfaceOnly:=True
End With
End Sub
'===========================================================
'ワークシート等のオブジェクト変数への設定を一括化して行うための
'クラスにワークシートを設定する
'ダミー引数はマクロ実行対象としての表示を避けるため
Sub makeComSet(Optional dummy As String)
Set comSet = New comSetClass
With comSet
Set .dataSheet = ThisWorkbook.Sheets("帳票")
Set .detailSheet = ThisWorkbook.Sheets("詳細")
Set .refTableSheet = ThisWorkbook.Sheets("対照表")
End With
End Sub
'===========================================================
'オブジェクト変数集約用のクラスに、表引き用の範囲を設定
Sub setLookupTable(Optional dummy As String)
Dim tempRange As Range
If comSet Is Nothing Then makeComSet
With comSet.refTableSheet
Set tempRange = .Range("A1").CurrentRegion
Set tempRange = Intersect(tempRange, tempRange.Offset(1, 1))
End With
Set comSet.lookupTable = tempRange
End Sub
'===========================================================
'表引き用のテーブルを生成する
'一行目は見出しを入れてあり、A2セルからデータを記入
'A列:見出し文字列,B列:帳票シートの列番,C列:詳細シートの該当アドレス
'対照表シートにボタンを設けて実行する
Private Sub makeRefTable()
Dim titleRange As Range, myCell As Range
Dim findCell As Range, destCell As Range
Const fieldNameRow As Long = 3 '帳票シートの見出しが入った行番
If comSet Is Nothing Then makeComSet
With comSet.refTableSheet
Set destCell = .Range("A2")
'指定セルと、UsedRangeの右下セルで囲まれるセル群をクリア
.Range(destCell, .Cells(.UsedRange.Rows(.UsedRange.Rows.Count).Row, .UsedRange.Columns(.UsedRange.Columns.Count).Column)).ClearContents
End With
With comSet.dataSheet
'見出しが入ったセル範囲
Set titleRange = .Range(.Cells(fieldNameRow, 1), .Cells(fieldNameRow, .Columns.Count).End(xlToLeft))
End With
For Each myCell In titleRange.Cells
On Error Resume Next
Set findCell = comSet.detailSheet.UsedRange.Find(What:=myCell.Value, LookIn:=xlValues, lookAt:=xlWhole)
If Not findCell Is Nothing Then
With destCell
.Value = myCell.Value
.Offset(0, 1).Value = myCell.Column
.Offset(0, 2).Value = findCell.Address(True, True, xlA1)
End With
Set destCell = destCell.Offset(1, 0)
End If
On Error GoTo 0
Next myCell
setLookupTable
End Sub
'===========================================================
'詳細シートのデータを、帳票シート(=データベース)に書き戻す・新規に書き込む
Private Sub writeData()
Dim keyRange As Range, destRange As Range
Dim myCell As Range, myRow As Range
Dim ID As Long
Const keyColumn As Long = 1
If comSet Is Nothing Then makeComSet
If comSet.lookupTable Is Nothing Then setLookupTable
'詳細シートのキー値を収納するセル範囲。実際のシートに合わせて設定要
'キー値は整数である事を前提にしている
Set keyRange = comSet.detailSheet.Range("C4")
If keyRange.Value = "" Then
'キー値が空の時、新レコードへ書き込む
ID = Application.WorksheetFunction.Max(comSet.dataSheet.Columns(keyColumn)) + 1
With comSet.dataSheet
Set destRange = .Cells(.Rows.Count, keyColumn).End(xlUp).Offset(1, 0)
For Each myRow In comSet.lookupTable.Rows
.Cells(destRange.Row, myRow.Cells(1).Value) = comSet.detailSheet.Range(myRow.Cells(2).Value).Offset(0, 1).Value
Next myRow
End With
destRange.Value = ID
keyRange.Value = ID
Else
On Error Resume Next
ID = keyRange.Value
Set destRange = comSet.dataSheet.Columns(keyColumn).Find(What:=ID, LookIn:=xlValues, lookAt:=xlWhole)
If Not destRange Is Nothing Then
With comSet.dataSheet
For Each myRow In comSet.lookupTable.Rows
.Cells(destRange.Row, myRow.Cells(1).Value) = comSet.detailSheet.Range(myRow.Cells(2).Value).Offset(0, 1).Value
Next myRow
End With
Else
MsgBox "Data not found!"
Exit Sub
End If
On Error GoTo 0
End If
End Sub
'===========================================================
'詳細シートのデータクリア
Private Sub clearData()
Dim myRow As Range
If comSet Is Nothing Then makeComSet
If comSet.lookupTable Is Nothing Then setLookupTable
For Each myRow In comSet.lookupTable.Rows
comSet.detailSheet.Range(myRow.Cells(2).Value).Offset(0, 1).ClearContents
Next myRow
End Sub
'===========================================================
'おまけ 列方向にもオートフィルタの様な機能をもたせる
'スピンボタン(フォームコンとロール)の操作により起動される
'見出しレベルの数値に応じて列を隠したり、再表示する
'スピンボタンにリンクするセルに dspLevel という範囲名をつけてある
Private Sub showHideColumn()
Dim levelRange As Range, myCell As Range
Const levelRow As Long = 4 '表示の判断に用いる数値を収納する行番号
Const startColumn As Long = 3 '表示有無の制御を開始する列番号
'クラスが生成されていなければ、生成+ワークシートオブジェクト設定
If comSet Is Nothing Then makeComSet
Application.ScreenUpdating = False
With comSet.dataSheet
Set levelRange = .Range(.Cells(levelRow, startColumn), .Cells(levelRow, .Columns.Count).End(xlToLeft))
End With
For Each myCell In levelRange.Cells
If myCell.Value <= Range("dspLevel").Value Then
myCell.EntireColumn.Hidden = False
Else
myCell.EntireColumn.Hidden = True
End If
Next myCell
Application.ScreenUpdating = True
End Sub
'☆ クラスモジュール comSetClass
'ワークシート等のオブジェクト変数を保持する機能のみ
'設定有無が一発で判定できるのでコードがスッキリする?
'たいした事をしていないのでカプセル化など気にしないで、
'単にPublic変数宣言で済ませる事も考えられる
Private myDataSh As Worksheet
Private myDetailSh As Worksheet
Private myRefTableSh As Worksheet
Private myLookupTable As Range
Public Property Set dataSheet(newSheet As Worksheet)
Set myDataSh = newSheet
End Property
Public Property Get dataSheet() As Worksheet
Set dataSheet = myDataSh
End Property
Public Property Set detailSheet(newSheet As Worksheet)
Set myDetailSh = newSheet
End Property
Public Property Get detailSheet() As Worksheet
Set detailSheet = myDetailSh
End Property
Public Property Set refTableSheet(newSheet As Worksheet)
Set myRefTableSh = newSheet
End Property
Public Property Get refTableSheet() As Worksheet
Set refTableSheet = myRefTableSh
End Property
Public Property Set lookupTable(newRange As Range)
Set myLookupTable = newRange
End Property
Public Property Get lookupTable() As Range
Set lookupTable = myLookupTable
End Property
'☆ 帳票シートモジュール
'===========================================================
'表示レベルの数値が変わったとき、スピンボタンの最大値を対応させる
Private Sub Worksheet_Change(ByVal Target As Range)
Dim levelRange As Range, myCell As Range
Const levelRow As Long = 4 '表示レベル数値の入った行番
Const startColumn As Long = 3 '表示有無の判定を開始する列番
Const mySpinnerName As String = "Spinner 1" 'スピンボタンの名前は決め打ち
If Target.Row <> levelRow Then Exit Sub
If comSet Is Nothing Then makeComSet
With comSet.dataSheet
Set levelRange = .Range(.Cells(levelRow, startColumn), .Cells(levelRow, .Columns.Count).End(xlToLeft))
End With
'Shapesだとエラーになる
Me.DrawingObjects(mySpinnerName).Max = Application.WorksheetFunction.Max(levelRange)
End Sub
'===========================================================
'キー列のWクリックで、詳細シートに転記・遷移
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim srcRange As Range, myCell As Range, lookupTable As Range
Dim myAddress As String
Const keyColumn As Long = 1 'イベント動作はキー列のみに限定とする
If Target.Column <> keyColumn Then Exit Sub
Cancel = True
If comSet Is Nothing Then makeComSet
With Me 'comSet.dataSheet
Set srcRange = .Range(Target, .Cells(Target.Row, .Columns.Count).End(xlToLeft))
End With
If comSet.lookupTable Is Nothing Then setLookupTable
On Error Resume Next
For Each myCell In srcRange.Cells
myAddress = ""
'lookupTableの1列目が列番、2列目がアドレス
myAddress = Application.WorksheetFunction.VLookup(myCell.Column, comSet.lookupTable, 2, False)
If myAddress <> "" Then
'Offsetを用いているので、myAddressの示すセルが、縦横方向に結合されていても動作する様です
comSet.detailSheet.Range(myAddress).Offset(0, 1).Value = myCell.Value
End If
Next myCell
On Error GoTo 0
comSet.detailSheet.Activate
End Sub