アクティブセル情報(値/アドレス/シリアル値/表示形式/フォーマットされた値)をユーザーフォーム上に表示するアドイン【Excel】

Worksheet_SelectionChangeイベント使えたらユーザーフォームに随時表示できるのになー

個人用マクロブックとかアドインだとどうするんだろう...RelaxToolsの十字カーソルはそれやってるしなー...

アドインからアクティブブックのWorksheet_SelectionChangeを使う方法

ググったらアッサリあった

パターン１：都度実行してMsgBoxに表示する

先方もMsgBoxに表示するものは既に作られているとのことですが、こちらも手始めに作成。何か次に繋げられるヒントはないかと思ったけどそんなことはなかった...

標準モジュール

Sub セル情報を都度MsgBoxに表示する()
  Dim Dicセル情報 As Object
  Set Dicセル情報 = Getセル情報(ActiveCell)
  
  Dim msg
  Dim key
  For Each key In Dicセル情報
    msg = msg & vbLf & key & ":" & Dicセル情報(key)
  Next
  MsgBox msg
End Sub

Function Getセル情報(Cell対象 As Range) As Object
  Dim Dic As Object
  Set Dic = CreateObject("Scripting.Dictionary")
  '値、シリアル値、表示形式、表示されている値、表示形式でフォーマットされた値
  With Cell対象
    Dic.Add "値", .Value
    Dic.Add "アドレス", .Address
    Dic.Add "シリアル値", .Value2
    Dic.Add "表示形式", .NumberFormatLocal
    Dic.Add "表示されている値", .Text
    Dic.Add "表示形式でフォーマットされた値", Format(.Value, .NumberFormatLocal)
    
  End With
  Set Getセル情報 = Dic
End Function

パターン２：セルを移動するたびに表示更新する

たぶんこんなのが欲しいんじゃなかろうかと想像で作りました。

使い方は

アドイン有効化によって追加される右クリックメニューを実行すると

セルを選択する度にユーザーフォームの中身が書き換わる。
（確かに幅狭セルに対してRange.Textだと######になる...勉強になります）

うまく動かないときは

ThisWorkbook

Public Sub Workbook_Open()
  Set app = Application
End Sub

を実行(F5)する

あともう少しのところが難しい...

ThisWorkbookモジュール

Option Explicit

Public WithEvents app As Application
Const proc名 = "セル情報表示用フォーム呼び出し"
Const 表示名 = "セル情報表示用フォーム呼び出し"
Const key = "C"


Public Sub Workbook_Open()
  Set app = Application
End Sub

Private Sub app_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim Rng As Range: Set Rng = Target(1)
  With UserForm1.ListView1
    .ListItems(1).SubItems(2) = Rng.Value
    .ListItems(2).SubItems(2) = Rng.Address
    .ListItems(3).SubItems(2) = Rng.Value2
    .ListItems(4).SubItems(2) = Rng.NumberFormatLocal
    .ListItems(5).SubItems(2) = Rng.Text
    .ListItems(6).SubItems(2) = Format(Rng.Value, Rng.NumberFormatLocal)
  End With
End Sub

Private Sub Workbook_AddinInstall()
  Set app = Application
  Call AddMenu(proc名, 表示名, 1, key)

End Sub

Private Sub Workbook_AddinUninstall()
  On Error Resume Next
  Call DelMenu(表示名, key)

End Sub

標準モジュール

Option Explicit
Sub セル情報表示用フォーム呼び出し()
  Call アドインリフレッシュ
  UserForm1.Show vbModeless
End Sub
Private Sub アドインリフレッシュ()
  Application.ScreenUpdating = False
  Dim wbName As String: wbName = ActiveWorkbook.Name
  Call AddInシート表示(True)
  Call AddInシート表示(False)
  Application.ScreenUpdating = True
  Workbooks(wbName).Activate
End Sub
Private Sub AddInシート表示(OnOff As Boolean)
  With ThisWorkbook
    .IsAddin = Not (OnOff)
  End With
End Sub
  
' =========================================
' 右クリックメニュー追加、削除
' =========================================
Sub AddMenu(OnAction As String, Caption As String, Pos As Long, key As String)
    With CommandBars("Cell").Controls.Add(Before:=Pos)
        .Caption = Caption & "(&" & key & ")"
        .OnAction = OnAction
    End With
End Sub
Sub DelMenu(Caption As String, key As String)
  CommandBars("Cell").Controls(Caption & "(&" & key & ")").Delete
End Sub

ユーザーフォーム

適当にListViewを配置しておく。サイズとかはコード上で調整した方がいい。

UserForm1

Option Explicit

Private Sub ListView1_BeforeLabelEdit(Cancel As Integer)

End Sub

Private Sub UserForm_Initialize()
  With Me
    Call UserFormを初期化する
    Call ListViewを初期化する(.ListView1)
    Call ListViewに列を設定する(.ListView1)
    Call ListViewに項目リストを追加する(.ListView1)
  End With
End Sub

Private Sub UserFormを初期化する()
  With Me
    .Caption = "アクティブセル情報 " & ActiveWorkbook.Name & "_" & ActiveSheet.Name
    .Height = 200
    .Width = 400
  End With
End Sub

Private Sub ListViewを初期化する(myListView As ListView)
  With myListView
    .View = lvwReport           ''表示
    .LabelEdit = lvwManual      ''ラベルの編集
    .HideSelection = False      ''選択の自動解除
    .AllowColumnReorder = True  ''列幅の変更を許可
    .FullRowSelect = True       ''行全体を選択
    .Gridlines = True           ''グリッド線
    
    .Height = 100
    .Width = 350
  End With
End Sub

Private Sub ListViewに列を設定する(myListView As ListView)
  With myListView
    .ColumnHeaders.Add , "", "", 1
    .ColumnHeaders.Add , "項目", "項目", 150
    .ColumnHeaders.Add , "値", "値", 200
  End With

End Sub


Private Sub ListViewに項目リストを追加する(myListView As ListView)
  Dim my項目リスト: my項目リスト = my項目リスト_
  Dim i
  For i = 0 To UBound(my項目リスト)
    With myListView.ListItems.Add
      .SubItems(1) = my項目リスト(i)
    End With
  Next
  
End Sub

Private Function my項目リスト_()
  my項目リスト_ = Array("値", "アドレス", "シリアル値", "表示形式", "表示されている値", "表示形式でフォーマットされた値")
End Function

振り返り・新しく知ったこと

Public WithEvents app As Applicationで他ブックのイベントを作ることができる

これは他でも知りたかった方法だったのでこの収穫はかなり嬉しい

ただ、うまく動かないときは

ThisWorkbook

Public Sub Workbook_Open()
  Set app = Application
End Sub

を実行(F5)する必要があるのが惜しい

あともう少しのところが難しい...

WorkbookイベントからUserFormのプロシージャって呼べないの？

ここのTarget(Range型)を引数としてUserForm側のプロシージャに渡そうとするとエラーになる

なんでや

ThisWorkbook

Private Sub app_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim Rng As Range: Set Rng = Target(1)
  With UserForm1.ListView1
    .ListItems(1).SubItems(2) = Rng.Value
以下略