VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. Other
  3. detailSheet


Accessの帳票フォームと詳細フォームを、Excelワークシートで模擬

珍しく実務で使える?エクセルらしいテーマです
Accessで帳票フォームのレコードをクリックすると、詳細フォームが表示されて編集できる様になる形をよく用いますが
人様に使っていただくために、同様の事をExcelでやってみようと思い立ちました。
詳細シートへの転記は最初関数でReadOnlyにしようと考えていましたが、何故かとても重いので、試行錯誤している内に
対照表を自動生成して、その対照表を表引きして転記する形を採用し、どうせならと書き戻す・新規作成部分も組み込んでしまいました
当初考えていたVBAに詳しくない人にも分かる簡単なコードという構想からはかけ離れてしまいました。クラスまで使っていますし(^^;)

帳票シート
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