Excel5.0ダイアログシートを用いたセル参照

Excel5.0ダイアログ

  「Excel5.0ダイアログ」は、昔のExcelで、現在のユーザーフォーム代わりに使用されていたものです。OptionButtonやTextBox(5.0ではEditBoxと呼ばれる)等が配置でき、マクロで制御します。
 ユーザーフォームの方が拡張性が高く、イベントドリブン型のプログラムを使用できるため、私は基本的にフォームを使用していますが、セル参照のための「RefEdit」コントロールはエラーが多いため使用していません。
 そのため、プログラムでユーザーにセルを参照してもらう場合、「Excel5.0ダイアログ」使用しています。これはExcel5.0ダイアログで、セル参照するためのメモとサンプルコードです。

ポイント

 ・Excel5.0ダイアログシート
 ・選択中のセルアドレスをEditBoxに表示
 ・EditBoxが空白時の対応例
 ・セル参照の文字列をブック名・シート名、セルアドレスに分割
 ・名前の定義されたセルのアドレス表示
 ・列をセルアドレスに変換
 ・参照先が複数の場合の対応

 [サンプルファイル] 30kb
  Excel5.0ダイアログシートが挿入されており、サンプルコードが記述されているExcelファイル


Excel5.0ダイアログシートの挿入

 1.シートタブを右クリック
 2.挿入を選択→「挿入」ダイアログが表示される
 3.「MS Excel5.0 ダイアログ」を選択し「OK」

EditBoxの挿入

 1.「開発」タブを選択
 2.挿入をクリック
 3.「フォームコントロール」の「テキストフィールド」を選択
 4.ダイアログシートの任意の場所をクリック→EditBoxが挿入される

EditBoxの属性選択

 EditBoxを右クリックし「コントロールの書式設定」をクリック
 「コントロールの書式設定」ダイアログが表示される



 ダイアログの「コントロール」タブを選択し、「入力できるデータ」を「参照先」に設定し「OK」


Excel5.0ダイアログの表示

 表示にはマクロを使用。以下はサンプルコード。 ※"Dialog1"はシート名

Sub E5_Dialog_1()
    If ThisWorkbook.Sheets("Dialog1").Show = False Then Exit Sub
End Sub

 上記のマクロの実行結果

 ・ダイアログの「キャンセル」ボタンをクリックすると、「False」が返る。
 ・セル範囲とは関係のない文字列を入力し「OK」をクリックすると、エラーが表示。

 EditBox右端のボタンを押すと、下図のようにダイアログが折りたたむ。


EditBoxに選択中のセルアドレスを表示

 ダイアログ表示時に、EditBoxに選択中のセルアドレスを表示するサンプルコード

Sub E5_Dialog_2()
    With ThisWorkbook.Sheets("Dialog1")
        .EditBoxes(1).Text = Selection_Address()
        If .Show = False Then Exit Sub
        MsgBox .EditBoxes(1).Text
    End With
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function Selection_Address() As String
    With Excel.Application
        If TypeName(.Selection) = "Range" Then
            Selection_Address = .Selection.Areas(1).Address
        End If
    End With
End Function

 EditBoxは、上記のEditBoxes(1)のようにIndexで指定。
 EditBoxの文字列の取得・設定にはTextプロパティを使用。



EditBoxが空白で「OK」を押した場合の対応

 EditBoxが空白だと、再度ダイアログを表示するサンプルコード

Sub E5_Dialog_3()
    With ThisWorkbook.Sheets("Dialog1")
        Do
            If .Show = False Then Exit Sub
            If Len(.EditBoxes(1).Text) <> 0 Then Exit Do
        Loop
        MsgBox .EditBoxes(1).Text '参照元セルアドレス
    End With
End Sub

 ダイアログを閉じた時に、EditBoxの値を調べ、空白の場合はDo~Loopで再度表示。


参照したセルアドレスから該当セルのプロパティを取得・設定

 参照文字列から、該当セル範囲のセルの個数を取得するサンプルコード

Sub E5_Dialog_4()
    With ThisWorkbook.Sheets("Dialog1")
        Do
            If .Show = False Then Exit Sub
            If Len(.EditBoxes(1).Text) <> 0 Then Exit Do
        Loop
        '参照したセル範囲のセル個数を取得
        MsgBox Application.Range(.EditBoxes(1).Text).Cells.Count
    End With
End Sub

 他ブック・他シートのセル参照も可能。


参照したセルアドレスからブック名・シート名・セルアドレスを取得

 参照文字列から、シート名、セルアドレスを取得

Sub E5_Dialog_5_1()
    With ThisWorkbook.Sheets("Dialog1")
        Do
            If .Show = False Then Exit Sub
            If Len(.EditBoxes(1).Text) <> 0 Then Exit Do
        Loop
        'シート名の取得
        MsgBox Application.Range(.EditBoxes(1).Text).Worksheet.Name
        'セルアドレスの取得
        MsgBox Application.Range(.EditBoxes(1).Text).Address
    End With
End Sub

 ブック名の取得には、セル参照の書式を知る必要がある。

◆セルの参照例


【ブック名】
 他ブックを参照した場合は、ブック名の前後に [ ] が付く。

【シート名】
 他シートを参照した場合、シート名の後に「!」が付く。

【セルアドレス】
 A1形式で、行列ともに絶対参照の「$」が付く。
 複数範囲を選択の場合は「,」で区切られる。

【その他】
 ブック名、シート名に「'」(シングルクオンテーション)が入っている場合、
 ブック名、「!」、「'」それぞれの前に、「'」が追加される。

◆シート名に「'」が入っている(Sheet'2)の場合の参照例

 参照文字列から、ブック名・シート名・セルアドレスを取得するサンプルコード

Sub E5_Dialog_5_2()
    Dim strBookName As String
    Dim strSheetName As String
    Dim strAreaAddress As String
    With ThisWorkbook.Sheets("Dialog1")
        Do
            If .Show = False Then Exit Sub
            If Len(.EditBoxes(1).Text) <> 0 Then Exit Do
        Loop
        With .EditBoxes(1)
            'ブック・シート名、セルアドレスの取得
            strBookName = Get_BookName(.Text)
            strSheetName = Range(.Text).Worksheet.Name
            strAreaAddress = Range(.Text).Address
        End With
        strBookName = "ブック名:" & strBookName & vbCrLf
        strSheetName = "シート名:" & strSheetName & vbCrLf
        strAreaAddress = "セルアドレス:" & strAreaAddress
        MsgBox strBookName & strSheetName & strAreaAddress
    End With
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function Get_BookName(ByVal ET As String) As String
    'ブック名を返す
    Dim lngBookSepF As Long
    Dim lngBookSepE As Long
    Dim strBN As String
    lngBookSepF = InStr(1, ET, "[", vbBinaryCompare)
    lngBookSepE = InStrRev(ET, "]", -1, vbBinaryCompare)
    If lngBookSepE = 0 Then
        strBN = Excel.Application.ActiveWorkbook.Name
    Else
        strBN = Mid$(ET, lngBookSepF + 1, lngBookSepE - (lngBookSepF + 1))
    End If
    Get_BookName = Sgl_String_Search(strBN)
End Function
'-------------------------------------------------------------------------------------------------------

Private Function Sgl_String_Search(ByVal objName As String) As String
    Dim lngStrCount As Long
    Dim bolStrFlg As Boolean
    Dim strString As String
    Const conSgl As String = "'"
    If InStr(1, objName, conSgl, vbBinaryCompare) <> 0 Then
        If Left$(objName, 1) = conSgl Then objName = Mid$(objName, 2)
        If Right$(objName, 1) = conSgl Then objName = Left$(objName, Len(objName) - 1)
        If InStr(1, objName, conSgl, vbBinaryCompare) <> 0 Then
            Do
                lngStrCount = lngStrCount + 1
                strString = Mid$(objName, lngStrCount, 1)
                If strString = conSgl Then
                    If bolStrFlg Then
                        objName = Left$(objName, lngStrCount - 1) & Mid$(objName, lngStrCount + 1)
                        lngStrCount = lngStrCount - 1
                        bolStrFlg = False
                    Else
                        bolStrFlg = True
                    End If
                End If
                If Len(objName) < lngStrCount Then Exit Do
            Loop
        End If
    End If
    Sgl_String_Search = objName
End Function

 他ブックを参照しない場合はアクティブブック名、他シートを参照しない場合はアクティブシート名を返す。
 シングルクオンテーションの処理が重要。


列をセルアドレスに変換

 列を参照した場合に、列をセルアドレスに変換するサンプルコード。その後の処理を考慮し、変換後のセル範囲は、そのシートで使用しているセルの中で、最も下のセルを基準している。

Sub E5_Dialog_6()
    Dim i As Long
    Dim strBookName As String
    Dim strSheetName As String
    Dim strAreaName As String
    With ThisWorkbook.Sheets("Dialog1")
        Do
            If .Show = False Then Exit Sub
            If Len(.EditBoxes(1).Text) <> 0 Then Exit Do
        Loop
        strBookName = ActiveWorkbook.Name
        strSheetName = ActiveSheet.Name
        strAreaName = .EditBoxes(1).Text
        i = InStrRev(strAreaName, "!")
        If i <> 0 Then strAreaName = Mid$(strAreaName, i + 1)
        strAreaName = Col_Cell_Address(strBookName, strSheetName, strAreaName)
        MsgBox strAreaName 
    End With
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function Col_Cell_Address(WB As String, SH As String, AN As String) As String
    Dim lngInstr As Long
    Dim strClAdS As String
    Dim strClAdE As String
    Dim bolSpCell As Boolean
    Col_Cell_Address = AN
    With Excel.Application.Workbooks(WB).Worksheets(SH)
        lngInstr = InStr(1, AN, ":", vbBinaryCompare) '「:」を探す
        If lngInstr = 0 Then Exit Function
        '列を選択した場合、それをセル範囲のアドレスに変換
        If Not IsNumeric(Mid$(AN, lngInstr - 1, 1)) Then
            strClAdS = Left$(AN, lngInstr - 1)
            strClAdE = Mid$(AN, lngInstr + 1)
            If Left$(strClAdS, 1) = "$" Then Else strClAdS = "$" & strClAdS
            If Left$(strClAdE, 1) = "$" Then Else strClAdE = "$" & strClAdE
            lngInstr = .Cells.SpecialCells(xlCellTypeLastCell).Row
            Col_Cell_Address = strClAdS & "$1" & ":" & strClAdE & "$" & lngInstr
        End If
    End With
End Function

 サンプルでは、アクティブブック・アクティブシートを元にしている。


参照元のセル範囲が複数の場合の対応

 参照元のセル範囲が、複数の場合の対応処理サンプルコード。セル参照が複数の場合「,」で区切られる。

Sub E5_Dialog_7()
    Dim i As Long
    Dim strCheckCol As String
    Dim strBookName As String
    Dim strSheetName As String
    Dim strAreaName As String
    Dim strEditText As String
    Dim varEditText As Variant
    Dim varArray(0 To 0) As Variant
    With ThisWorkbook.Sheets("Dialog1")
        Do
            If .Show = False Then Exit Sub
            If Len(.EditBoxes(1).Text) <> 0 Then Exit Do
        Loop
        strEditText = .EditBoxes(1).Text
    End With
    If Len(strEditText) = 0 Then Exit Sub
    If InStr(1, strEditText, ",", vbBinaryCompare) = 0 Then
        'ひとつのセル範囲
        varArray(0) = strEditText
        varEditText = varArray
    Else
        '複数のセル範囲
        varEditText = Split(strEditText, ",")
    End If
    For i = LBound(varEditText) To UBound(varEditText)
        strEditText = varEditText(i)
        'ブック・シート名、セルアドレスの取得
        strBookName = Get_BookName(strEditText)
        strSheetName = Range(.Text).Worksheet.Name
        strAreaName = Range(.Text).Address
        strBookName = "ブック名:" & strBookName & vbCrLf
        strSheetName = "シート名:" & strSheetName & vbCrLf
        strAreaName = "セルアドレス:" & strAreaName
        MsgBox strBookName & strSheetName & strAreaName
    Next
End Sub
'-------------------------------------------------------------------------------------------------------

Private Function Get_BookName(ByVal ET As String) As String
    'ブック名を返す
    Dim lngBookSepF As Long
    Dim lngBookSepE As Long
    Dim strBN As String
    lngBookSepF = InStr(1, ET, "[", vbBinaryCompare)
    lngBookSepE = InStrRev(ET, "]", -1, vbBinaryCompare)
    If lngBookSepE = 0 Then
        strBN = Excel.Application.ActiveWorkbook.Name
    Else
        strBN = Mid$(ET, lngBookSepF + 1, lngBookSepE - (lngBookSepF + 1))
    End If
    Get_BookName = Sgl_String_Search(strBN)
End Function
'-------------------------------------------------------------------------------------------------------

Private Function Sgl_String_Search(ByVal objName As String) As String
    Dim lngStrCount As Long
    Dim bolStrFlg As Boolean
    Dim strString As String
    Const conSgl As String = "'"
    If InStr(1, objName, conSgl, vbBinaryCompare) <> 0 Then
        If Left$(objName, 1) = conSgl Then objName = Mid$(objName, 2)
        If Right$(objName, 1) = conSgl Then objName = Left$(objName, Len(objName) - 1)
        If InStr(1, objName, conSgl, vbBinaryCompare) <> 0 Then
            Do
                lngStrCount = lngStrCount + 1
                strString = Mid$(objName, lngStrCount, 1)
                If strString = conSgl Then
                    If bolStrFlg Then
                        objName = Left$(objName, lngStrCount - 1) & Mid$(objName, lngStrCount + 1)
                        lngStrCount = lngStrCount - 1
                        bolStrFlg = False
                    Else
                        bolStrFlg = True
                    End If
                End If
                If Len(objName) < lngStrCount Then Exit Do
            Loop
        End If
    End If
    Sgl_String_Search = objName
End Function

Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.