personal.xls 強化講座

Home What's
New
Site
Concept
生産性向上
基本テクニック		 トラブル回避
テクニック		 生産性向上
リンク		 personal.xls
強化講座		 生産性向上
ツール		 Site
Map		 Coffee
Break		 Guest
Book		 地球風
画像館		 Q&A Salon
EXCELの質問はこちらへ

　

１．あるとちょっと便利なマクロ（16-20）
05/06/2000 -

このページのマクロ（テキスト）の表示

(16) ファイルメニューに隠しメニューを追加する
　


EXCELの「ファイル(F)」メニューには、上から３番目に「閉じる(C)」という機能があります。このファイルメニューをShiftキーを押しながら選択（クリック）すると、上から３番目は「すべて閉じる(C)」というメニューに変っています。これが隠しメニューで、読んで字のごとく複数のブックを開いていても一気に閉じてしまいます。

これは（ささやかながら）ちょっと便利な機能なんですが、なにぶん隠しメニューなので普段なかなか存在を思い出しません。そこで、標準の「ファイル(F)」メニューの「閉じる(C)」の下にこの「すべて閉じる」機能を追加してしまいましょう。

このマクロをpersonal.xlsに追加しておくと、標準の「ファイル(F)」メニューが右のようになります。


　

裏メニュー追加

「すべて閉じる」が追加された標準の 「ファイル(F)」メニュー
　 　
　
Sub auto_open()
'
    隠しMenu追加 1

'auto_open に既に他のマクロが記述されている場合には、この１行を追加する
'
End Sub

Sub 隠しMenu追加(num%)
'
' Shirt + ファイル(F) メニューにある「すべて閉じる」機能を標準のファイルメニューに追加する
'   （ただし、隠しメニューには「すべて閉じる」が２つになってしまう）
'
    Dim tmpCBar As CommandBar
    Dim tmpCMenu As CommandBarControl
 
    Set tmpCBar = Application.CommandBars("Worksheet Menu Bar")
'    Set tmpCMenu = tmpCBar.Controls("ファイル(&F)")     'Excel97は”ファイル”を半角に
    Set tmpCMenu = tmpCBar.Controls(1)
 
    With tmpCMenu
        .Controls.Add Type:=msoControlButton, Before:=4, Temporary:=True
        With .Controls(4)
            .Caption = "すべて閉じる(&F)"
            .FaceId = 106
            .OnAction = "CloseAllBooks"
        End With
    End With
'
End Sub
Sub CloseAllBooks()
'
    Dim ws As Variant
 
    For Each ws In Workbooks
        If ws.Name <> ThisWorkbook.Name Then
            ws.Close
        End If
 
    Next
'
End Sub

←目次へ戻る　/　このページのマクロ（テキスト）の表示

(17) シートの順番をシート名の50音順で並べ替える
　
アクティブなブックのシート（Sheet1 とか Sheet2 とかデフォルトの名前がついているもの）を、50音順の昇順で並べ替えてしまうマクロです。

personal.xls の一番先頭に、Option Compare Text という宣言を入れるのを忘れないでください。
これを入れないと、文字列の比較がバイナリモードになってしまって、50音順での並べ替えになりません。
　
　 　
　
 
Sub sheet_sort()        'シートを50音順に並べ替える
 
    '全てのモジュールより前に Option Compare Text という文字列比較をテキストモードにする宣言を忘れないように
 
    Dim ws As Variant
    Dim sheet_cnt As Integer
    Dim sheet_name(256) As String       '256シートまでOK（Excelの制限ではない）
    Dim tmp_name As String
 
    Dim i%
    Dim j%
 
    sheet_cnt = 0
    For Each ws In Worksheets
        If Sheets(ws.Name).Visible = True Then
            sheet_cnt = sheet_cnt + 1
            sheet_name(sheet_cnt) = ws.Name
        End If
    Next
 
    If sheet_cnt = 1 Then Exit Sub
    If sheet_cnt > 256 Then Exit Sub
 
    For i = 1 To sheet_cnt - 1          'いわゆるバカソート
        For j = i + 1 To sheet_cnt
            If sheet_name(i) > sheet_name(j) Then
                tmp_name = sheet_name(j)
                sheet_name(j) = sheet_name(i)
                sheet_name(i) = tmp_name
            End If
        Next
    Next
 
    For i = 1 To sheet_cnt - 1
        Sheets(sheet_name(i)).Select
        Sheets(sheet_name(i)).Move Before:=Sheets(i)
    Next
 
    Sheets(1).Select
 
End Sub
　 　

←目次へ戻る　/　このページのマクロ（テキスト）の表示

(18) 電卓起動機能を追加する
　
EXCELを使っているときに、ちょっとした検算などで電卓を使いたくなることがあります。
しかし、そのたびに 「スタートボタン」 「プログラム」 「アクセサリ」 「電卓」 とやるのは、あまりスマートではありませんし、一旦EXCELに戻ってからまた電卓を使おうとする場合にはアプリケーションを切替えないといけません。既に起動させていることを忘れてスタートボタンから呼び出すと、電卓が複数立ち上がってしまったりします。

そこで、EXCELから一発で電卓を起動できるようにしてしまいましょう。複数立ち上がらないように考慮しています。
（メニューに追加する方法も、あわせて修正しました→こちら）

最近作ったマクロでは（簡単な割に）かなりヒット作品で、大変重宝しております。同僚も喜んで使っています。
　
　 　
　
Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassNams As String, _
                         ByVal lpWindowName As String) As Long

Sub Dentaku()
'
    Dim strClassName As String
    Dim res As Long
    Dim lngProcessId As Long
 
    strClassName = "SciCalc"
    res = FindWindow(strClassName, vbNullString)
 
    If res = 0& Then        '電卓を起動する
        lngProcessId = Shell("Calc.exe", vbNormalFocus)
    Else                    '既に電卓が立ち上がっているときはアクティブにする
        AppActivate "電卓"
    End If
'
End Sub
　 　
　
2005.10.23 追記　

このコンテンツを書いたのは2001/6/23でしたが、Excel2000以降では（Excel2002(XP)・Excel2003でも）標準で電卓機能のボタンがあったことに気づきました。
したがって、わざわざマクロを書かなくても簡単に電卓起動をツールバーに出しておくことが出来ます。

まず、「表示(V)」「ツールバー(T)」「ユーザー設定(C)」とします。またはツールバー上の任意の場所で右クリックして、表示されたコンテキストメニューから一番下の「ユーザー設定(C)」とします。
すると、「ユーザー設定」ダイアログが表示されますので、「コマンド」タブを開き、「分類(G)」側で「ツール」を選び、「コマンド(D)」側でカメラボタンの次にある「電卓マークのユーザー設定ボタン」を探します（下左図）。

このボタンをツールバーの適当な場所までドラッグ・ドロップします（マウスで移動させて適当な場所でマウスを離します）。
なお、ツールバーだけでなく、メニューバー上にもボタンを置くことも可能です。たとえば「ファイル(F)」と「編集(E)」の間にボタンを置くことも出来ます。

その後、ツールバーに置いたそのボタンを右クリックして、ボタンの名前を「電卓の起動」などと機能が分かるように変更しておきます（下右図）。
　
　 これで、ユーザー設定ダイアログを閉じれば終わりです。
あとは、このボタンをクリックすれば電卓が起動します。なお、何回ボタンを押しても、電卓は１つしか起動しません。
　
　 　

←目次へ戻る　/　このページのマクロ（テキスト）の表示

(19) フォント設定の一覧を作成する
　
トラブル回避テクニックの１１．フォント設定を見直せ！で、フォント設定を見直しましょうという話を出しましたが、画面を拡大して目視で確認するのも大変なので、フォント設定の一覧表を作成するマクロを作ってみました。
　
　 以下のマクロを実行すると、現在アクティブなシートの（文字や数値が入力されている）セルのフォント種類と文字サイズを全て調査し、新規Bookを開いて下のような一覧表を作成します。
この一覧表のセル番号をダブルクリックすると、基のシートのそのセル番号を選択した状態の表示に切り替わります。
例えば、下の図でセルF3に入っている”D21”という部分をダブルクリックすると、基のシートのセルD21にカーソルがある状態で表示されます。これにより、フォントが他と異なっているセルを見つけ出して、容易に修正することが可能となります。
　
　
（実行結果サンプル）

　
　

　・2001.11.12　一覧表の表示にフォント種類とサイズを反映するように改修しました
　・2002.07.15　作成したフォント一覧表のセル番号をダブルクリックすると、元のｼｰﾄの当該セルを選択するようにマクロを埋め込む
　　改修をしました。（EXCEL2000で稼動確認しています）
　　例えば、下の実行結果サンプルで、A列の3行目”B8”と表示されているセルをダブルクリックすると、元のシートのB8セルが選択
　　された状態になります。これで、あるフォント種類・フォントサイズのセルを確認・修正しやすくなりました。
　・2003.07.27　このマクロは、作成したフォント一覧表（新規ブック）にマクロを埋め込む処理をしています。そのため、Excel2002では、
　　　　　　　　　　セキュリティのエラーが出る場合があります（下図）。

　　　　　　　　　　

　　　　　　　　　その場合は、「ツール(T)」 「マクロ(M)」 「セキュリティ(S)」で右図のように「Visual Basic プロジェクトへのアクセスを
　　　　　　　　　信頼する(V)」チェックボックスをオンにすることで動くようになります。

　　　　　　　　　　ただし、マクロウィルスをガードできるアンチウィルスソフトを導入した環境で使うことが望ましいでしょう。
　　　　　　　　　　下のマクロで　'マクロ埋め込み　のコメントがある1行を削ってしまっても良いですが。


　　　　　　　　　　
　 　
　
 
Sub font_check()                    'フォント設定一覧作成（オートシェイプの文字は除く）　Option Base 1 が前提
'
    Dim tmpRange As Range
    Dim sheet_name As String
 
    Dim font_settei() As String
    Dim font_address() As String
 
    Dim tmp_font_settei As String
    Dim tmp_font_address As String
 
    Dim tmpCount As Long
    Dim i As Long, j As Long, k As Long
    Dim sort1 As String, sort2 As String
 
    Dim str_macto As String
 
    str_macto = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & _
                vbNewLine & vbTab & "If Target.Row < 3 Or _" & _
                vbNewLine & vbTab & "   Target.Value = " & Chr$(34) & Chr$(34) & " Then" & _
                vbNewLine & vbTab & "    Exit Sub" & _
                vbNewLine & vbTab & "End If" & _
                vbNewLine & vbTab & "Cancel = True" & _
                vbNewLine & vbTab & "Workbooks(" & Chr$(34) & ActiveWorkbook.Name & Chr$(34) & ").Activate" & _
                vbNewLine & vbTab & "Sheets(" & Chr$(34) & ActiveSheet.Name & Chr$(34) & ").Select" & _
                vbNewLine & vbTab & "Workbooks(" & Chr$(34) & ActiveWorkbook.Name & Chr$(34) & ").Sheets(" & Chr$(34) & ActiveSheet.Name & Chr$(34) & ").Range(Target.Value).Select" & _
                vbNewLine & "End Sub"
 
    sheet_name = ActiveSheet.Name
    tmpCount = 0
    For Each tmpRange In ActiveSheet.UsedRange              'UsedRangeは使用している範囲全体が全て選択される
        If Not IsError(tmpRange.Value) Then                 '#VALUE!や#DIV/0!などのエラーがあるとValueが参照できない
            If tmpRange.Value <> "" Then
                tmpCount = tmpCount + 1
            End If
        End If
    Next
    If tmpCount = 0 Then
        MsgBox "文字・数値が入力されているセルがありません"
        Exit Sub
    End If
 
    ReDim font_settei(tmpCount)
    ReDim font_address(tmpCount)
 
    i = 0
    For Each tmpRange In ActiveSheet.UsedRange
        If Not IsError(tmpRange.Value) Then                         '#VALUE!や#DIV/0!などのエラーがあるとValueが参照できない
            If tmpRange.Value <> "" Then
                i = i + 1
                If IsNull(tmpRange.Font.Name) Then                  '1つのセルに複数のフォント種類が混ざっている場合はNullが返る
                    font_settei(i) = "フォント混在"
                Else
                    font_settei(i) = tmpRange.Font.Name
                End If
                If IsNull(tmpRange.Font.Size) Then                  '1つのセルに複数のサイズが混ざっている場合はNullが返る
                    font_settei(i) = font_settei(i) & ",サイズ混在"
                Else
                    font_settei(i) = font_settei(i) & "," & Format(tmpRange.Font.Size, "000.00")
                End If
                font_address(i) = tmpRange.Address(rowabsolute:=False, columnabsolute:=False, ReferenceStyle:=xlA1)
                font_address(i) = Format((tmpRange.Column * 100000 + tmpRange.Row), "0000000") & font_address(i)
            End If
        End If
    Next
 
    If tmpCount < 3 Then
        DoEvents
    Else
        For i = 1 To tmpCount - 1               'いわゆるバカソート
            For j = i + 1 To tmpCount
 
                sort1 = font_settei(i) & font_address(i)
                sort2 = font_settei(j) & font_address(j)
                If sort1 > sort2 Then
                    tmp_font_settei = font_settei(i)
                    tmp_font_address = font_address(i)
                    font_settei(i) = font_settei(j)
                    font_address(i) = font_address(j)
                    font_settei(j) = tmp_font_settei
                    font_address(j) = tmp_font_address
                End If
            Next
        Next
    End If
 
    Workbooks.Add
    Sheets("Sheet1").Name = sheet_name
    Rows("3:3").Select                              '見出し固定
    ActiveWindow.FreezePanes = True
                                                    'マクロ埋め込み
    ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule.AddFromString str_macto  '*****
 
    j = 0
    tmp_font_settei = ""
    For k = 1 To tmpCount
        If font_settei(k) <> tmp_font_settei Then
            j = j + 1
            If j > 255 Then
                Exit For
            End If
            Cells(1, j).Value = Left(font_settei(k), InStr(font_settei(k), ",") - 1)
            Cells(2, j).Value = Right(font_settei(k), (Len(font_settei(k)) - InStr(font_settei(k), ",")))
            If Cells(1, j).Value <> "フォント混在" Then
                Columns(j).Font.Name = Cells(1, j).Value        'フォント混在の場合はEXCELに設定した標準フォントとなる
            End If
            If IsNumeric(Cells(2, j).Value) Then
                Columns(j).Font.Size = Cells(2, j).Value        'サイズ混在の場合はEXCELに設定した標準フォントサイズとなる
                Cells(2, j).Value = Cells(2, j).Value & "pt"
            End If
            font_address(k) = Mid(font_address(k), 8)
            Cells(3, j).Value = font_address(k)
            tmp_font_settei = font_settei(k)
            i = 3
        Else
            i = i + 1
            If i > 65536 Then
                Exit For
            End If
            font_address(k) = Mid(font_address(k), 8)
            Cells(i, j).Value = font_address(k)
        End If
    Next
    Rows("1:2").Select
    Selection.Font.Bold = True
    Selection.Font.ColorIndex = 5
    Cells.Select
    Cells.EntireColumn.AutoFit
    Selection.CurrentRegion.Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    Cells(1.1).Select
    Windows.Arrange ArrangeStyle:=xlArrangeStyleHorizontal
'
End Sub
　
　 　

←目次へ戻る　/　このページのマクロ（テキスト）の表示

(20) 選択したセルの情報を表示する
　

これは皆さんご存知だと思いますが、Excelでは画面下に選択したセルの数値の合計や平均などが表示されます。これは標準機能です。何を表示させるかは、表示エリアを右クリックして出てくるコンテキストメニューから選ぶことが出来ます。（図20-1）

一見単純な機能のように思えますが、結構考えられてます。
たとえば、書式設定が日付になっているセルが含まれていると、合計や平均、最大値・最小値とも日付の書式で表示されます（図20-3）。ただし、同じ選択範囲でも日付以外の書式のセルから選択を始めると、数値としての合計や平均などが表示されます（図20-4）。
下の例では、図20-3はA8からB15を選択した状態ですが、図20-4はB8からA15を選択した状態です。

同様に、選択範囲の最初のセルが時刻表示の書式だと、画面下の表示も時刻書式になります。

さらに、Ctrlキーを押しながら複数のセル範囲を選択した場合、その選択範囲が重なっていても、重複部分は画面下の計算結果にダブって反映されることはありません（図20-2）。

　

図20-1


図20-2
　
B1-B3 と A2-C2 をCtrlを押しながら選択した状態
　

　
図20-3

　
図20-4

　
　

さて、ここからが本題です。この機能は数値データをいろいろ確認する局面などで便利なんですが、合計を見たい、平均を見たい、最大値を見たいなど目的が複数あると、いちいち右クリックして表示を切り替えないといけないのが難点です。

そこで、これらを一度で表示してしまうマクロをpersonal.xlsに追加してしまうことを思いつきました。ちょうど、最近公開したDirTools Ver2.6で似たような機能を追加したので、それをアレンジしました。ただし、画面下のステータスバーに自動的に表示させるのはpersonal.xlsでは難しいので、右クリックメニューに機能を追加する形にしています。（強化講座その４で紹介しています）

　・2003.7.13　選択セルの重複チェックロジックと選択セル数が多い時の警告メッセージ出力ロジックを改修（改良）しました。
　　　　　　　　　　これで、2〜3列程度なら、列全体を選択して実行することも可能になりました。

　・2004.10.11　文字数合計の表示を追加するように改良しました。
　　　　　　　　　　また、ユーザーから「表示される情報をセルに貼り付けるなどしたい場合がある」との意見を頂いたので、
　　　　　　　　　　新規ブックを開いて表示情報をセットする機能（選択可）を追加しました。

　・2005.2.20　このマクロを公開してから既に1年半強経ちますが、Excelの標準機能では非表示になっている行や列が
　　　　　　　　　　画面下の合計や平均等の集計の対象外となっていることに気づきました。
　　　　　　　　　　しかし、下のマクロでは非表示のセルも集計の対象にしてしまっています。
　　　　　　　　　　技術的には同じ仕様に出来ると思いますが、これまでのところ特に苦情や要望が寄せられていないので、
　　　　　　　　　　とりあえずは修正しません。仕様の違いを理解したうえでご使用下さい。
　　
　・2005.3.27　以下の機能追加・修正を行ないました。そのため、マクロも大幅に改修しました。
　　　　　　　　　　・文字形式で日付が入っているとエラーになるバグを改修
　　　　　　　　　　・文字数の最大最小値の表示、文字数集計から数値セルを除外（見た目の表示文字数と数値の桁数が異なるため）
　　　　　　　　　　・情報表示ポップアップ及び新規ブック展開時に元シートの選択セルの書式を反映（ただし、日付と通貨書式のみポップアップ表示には反映できず）
　　　　　　　　　　・表示情報を新規ブック上に展開する際、セル番号をダブルクリックすると元シートの該当セルを選択表示するマクロを埋め込み
　　　　　　　　　　新規ブックにマクロを埋め込む関係で、(19) フォント設定の一覧を作成する同様にセキュリティのエラーが出る場合があります。その時は、
　　　　　　　　　　(19)と同様に「ツール(T)」 「マクロ(M)」 「セキュリティ(S)」の設定をしてください。
　

　
（実行結果サンプル）
　

セルを選択してマクロを実行すると、図20-5（右図）のようにポップアップで情報を表示します。

・セルの個数　：　選択したセルの数
・データの個数　：　空白ではないセルの数

・文字セルの個数　：　文字列が入力されているセルの数（書式が文字列になっている数字は数値として扱われます）
・数値セルの個数　：　数値が入力されているセルの数

・文字数合計　：　文字数の合計
・文字数最大値[セル番地]　：　文字数の最大値とそのセルの位置
・文字数最小値[セル番地]　：　文字数の最小値とそのセルの位置

・数値最大値[セル番地]　：　数値の最大値とそのセルの位置
・数値最小値[セル番地]　：　数値の最小値とそのセルの位置

・数値合計　：　数値セルの最大値
・数値平均　：　数値セルの最小値

[セル番地]は、最大や最小が複数ある場合は、最初に見つかったセルの位置を表示します。

選択範囲に数値セルが無い場合は数値の最大・最小・合計・平均は表示されませんし（図20-6-1）、逆に文字セルが無い場合は文字数合計・最大・最小は表示されません（図20-6-2）。

最後に、「この情報を利用しますか？」 という確認メッセージと「はい(Y)」「いいえ(N)」ボタンが表示されます。デフォルトでは「いいえ(N)」ボタンが選択状態になっています（つまり、Enterキーを押せばダイアログが閉じます）。

ここで「はい(Y)」ボタンを押すと、下の図20-5-2のように新規ブックを開いてそこにポップアップ表示した情報をセットします。これにより、平均値などの情報をコピーペーストで利用することが可能です。

なお、下のシートで青字になっているセル番号（例えばセルB1に入っている$A$1:$B$4やセルC12に入っているA4）をダブルクリックすると、元のシートをアクティブにしてそのセルを選択します。これにより、最大値や最小値がどのセルかを簡単に調べることが出来ます。
　
図20-5
図20-5-2

　
図20-6-1


図20-6-2
　


数値セルでアクティブセル（最初に選択したセル）に書式が設定されている場合は、可能な限りその書式で最大値・最小値・合計・平均を表示します。これはExcelの画面下に表示されるものも同じです（図20-7、20-8）。
新規ブックを開いてセットする情報も、同じ書式で表示されます（図20-7-2、図20-8-2）。

この表示書式は、日付に限らず、時刻やパーセント、その他ユーザー設定書式でも、同じ書式で表示します（図20-9、20-9-2、20-10、20-10-2）。
ただし、通貨記号や分数など一部の書式については、ポップアップ表示は書式なしとなります（Format関数で使用する書式がセルの書式設定の表示形式とは異なるため）。

なお、標準以外の書式で数値を表示する場合は、その後ろにカッコで囲んで（シートに展開する場合は右隣のセルに）書式なしの数値も表示しています。
　
　
図20-7


図20-7-2

　
図20-8


図20-8-2
　
　
図20-9


図20-9-2

　
図20-10


図20-10-2
　 日付の書式では（合計など）オーバーフローして表示しきれない場合は、下のようなメッセージを表示した後に標準書式で結果を表示します。
（Excelの標準機能では、オーバーフローすると何も表示されなくなります）

　
　
　 図20-2と同じように、複数のセル範囲をCtrlキーを押しながら選択して、その選択範囲が重複している場合は、ダブりを取り除いた（1回だけ計算対象にして）結果を表示します（図20-11、20-11-2）。
　
　
図20-11

B1-B3 と A2-C2 をCtrlを押しながら選択した状態
　
図20-11-2

　
　 なお、下のマクロでは選択セル数が20000を超えると確認メッセージを出すようにしていますが、このしきい値はお使いのPCのスペックに合わせて適当に変えてください。

　
　
　 　
　 
Sub CellsInformation()                                  '2003/7/7-　選択したセルの情報を表示する
                                                        'アクティブなシートの選択セルのみ有効（対象）
'2004/10/9 文字数表示の追加、各種情報を新規ブックに展開する機能の追加
'2005/3/12 文字数の最大最小値の表示、文字数集計から数値セルを除外（見た目の表示文字数と数値の桁数が異なるため）
'2005/3/12 情報表示ポップアップ及び新規ブック展開時に元シートの選択セルの書式を反映（ただし、日付と通貨書式のみポップアップ表示には反映できず）
'2005/3/12 表示情報を新規ブック上に展開する際、セル番号をダブルクリックすると元シートの該当セルを選択表示するマクロを埋め込み
'2005/3/12 文字形式で日付が入っているとエラーになるバグを改修

    Dim cells_cnt As Long                               'セルの個数
    Dim numeric_cnt As Long                             '数値セルの個数
    Dim data_cnt As Long                                'データの個数（Null以外のセルの個数）
    Dim char_cnt As Long                                '文字数 2004/10/9
    Dim char_max As Long                                '文字数の最大値 2005/3/12
    Dim char_min As Long                                '文字数の最小値 2005/3/12
    Dim num_max As Double                               '数値の最大値
    Dim num_min As Double                               '数値の最小値
    Dim num_ave As Double                               '数値の平均値
    Dim num_sum As Double                               '数値の合計値
    Dim num_max_pos As String                           '数値最大値のセル番地
    Dim num_min_pos As String                           '数値最小値のセル番地
    Dim char_max_pos As String                          '文字数最大値のセル番地 2005/3/12
    Dim char_min_pos As String                          '文字数最小値のセル番地 2005/3/12
    Dim cells_addr() As String                          'セル番地（動的配列）
    Dim disp_format As String                           '数値の表示形式
    Dim cell_format As String                           '新規ブック用の表示形式 2005/3/12
    Dim newbook As New Workbook                         '新規ブック 2004/10/9
    Dim newbook_name As String                          '新規ブック名 2004/10/9
    Dim selected_range_address As String                '選択範囲アドレス 2004/10/9
    Dim str_macto As String                             '埋め込みマクロ用 2005/3/12
    Dim target_address As String                        '埋め込みマクロ用 2005/3/12

    Const cells_cnt_max As Long = 20000                 '警告用セル数最大値

    Dim cells_info As String                            '結果表示用 2005/3/12
    Dim i As Long
    Dim response As Integer                             'MsgBox戻り値用
    Dim tmpCell As Range
    Dim tmpAddr As String

    char_cnt = 0                                        '2004/10/9
    char_min = 0                                        '2005/3/12
    char_max = 0                                        '2005/3/12
    disp_format = ""                                    '2005/3/12
    cell_format = ""                                    '2005/3/12

    If TypeName(Selection) <> "Range" Then Exit Sub     'セル範囲以外を選択している場合は何もせず。
    If Selection.Cells.Count > cells_cnt_max Then       '2003/7/8 2005/3/12
        response = MsgBox("選択範囲のセルが" & cells_cnt_max & "以上あります。" & _
                          vbCr & "処理に時間がかかる可能性があります。" & _
                          vbCr & "処理を続けますか？" & vbCr, vbYesNo + vbExclamation + vbDefaultButton2, _
                          "確認メッセージ")
        If response = vbNo Then
            Exit Sub
        End If
    End If
    ReDim cells_addr(Selection.Cells.Count)             '選択範囲のセルの数で配列確定（この時点では重複あり）
    selected_range_address = Selection.Address          '2004/10/9

    '選択開始位置のセルが文字ではない場合、表示形式を保存 2005/3/12
    If IsNumeric(ActiveCell) Or (IsDate(ActiveCell) And VarType(ActiveCell) <> vbString) Then
        disp_format = ActiveCell.NumberFormatLocal
        cell_format = disp_format
        If InStr(1, disp_format, "G/標準", 1) > 0 Then
            disp_format = ""
            cell_format = ""
        End If          '標準は書式削除 2005/3/12
        If InStr(1, disp_format, "?", 1) > 0 Then disp_format = ""
                        '分数も書式削除（Format関数でうまく変換されないので） 2005/3/12
        If InStr(1, disp_format, "\", 1) > 0 Then
            disp_format = Application.WorksheetFunction.Substitute(disp_format, "\", "")
        End If          '通貨記号も書式削除（Format関数でうまく変換されないので） 2005/3/12
    End If

    For Each tmpCell In Selection.Cells                 '重複を排除しながら配列にセル番地を格納

        tmpAddr = tmpCell.Address(rowabsolute:=False, columnabsolute:=False)
        If cells_cnt = 0 Then
            cells_addr(1) = tmpAddr
            cells_cnt = 1
        Else
            If Selection.Areas.Count = 1 Then           '2003/7/8 選択範囲が１つなら重複チェックをしない
                i = cells_cnt + 1                       '2003/7/8
            Else                                        '2003/7/8
                For i = 1 To cells_cnt
                    If cells_addr(i) = tmpAddr Then
                        Exit For
                    End If
                Next
            End If                                      '2003/7/8
        End If

        If i > cells_cnt Or cells_cnt = 1 Then          '重複が無かった場合
            If i <> 0 Then cells_cnt = i
            cells_addr(cells_cnt) = tmpAddr
            If tmpCell.Value <> "" Then
                data_cnt = data_cnt + 1

                If IsNumeric(tmpCell) Or (IsDate(tmpCell) And VarType(tmpCell) <> vbString) Then
                                                            '文字列の日付は対象外とする 2005/3/12
                    numeric_cnt = numeric_cnt + 1
                    num_sum = num_sum + tmpCell.Value
                    If numeric_cnt = 1 Then
                        num_max = tmpCell.Value
                        num_max_pos = tmpAddr
                        num_min = tmpCell.Value
                        num_min_pos = tmpAddr
                    Else
                        If num_max < tmpCell.Value Then
                            num_max = tmpCell.Value
                            num_max_pos = tmpAddr
                        End If
                        If num_min > tmpCell.Value Then
                            num_min = tmpCell.Value
                            num_min_pos = tmpAddr
                        End If
                    End If
                Else
                    char_cnt = char_cnt + Len(tmpCell.Value)    '2004/10/9
                                                                '数値は集計対象外に 2005/3/12
                    If char_min = 0 Or char_min > Len(tmpCell.Value) Then   '2005/3/12
                        char_min = Len(tmpCell.Value)                       '2005/3/12
                        char_min_pos = tmpAddr                              '2005/3/12
                    End If                                                  '2005/3/12
                    If char_max < Len(tmpCell.Value) Then       '2005/3/12
                        char_max = Len(tmpCell.Value)           '2005/3/12
                        char_max_pos = tmpAddr                  '2005/3/12
                    End If                                      '2005/3/12
                End If

            End If
        End If

    Next

    target_address = Chr$(34) & "$B$1" & Chr$(34) & "," & _
                     Chr$(34) & "$C$9" & Chr$(34) & "," & _
                     Chr$(34) & "$C$10" & Chr$(34) & ","                                                '2005/3/12
    If cell_format <> "" Then                                                                           '2005/3/12
        target_address = target_address & Chr$(34) & "$D$12" & Chr$(34) & "," & _
                                          Chr$(34) & "$D$13" & Chr$(34)                                 '2005/3/12
    Else
        target_address = target_address & Chr$(34) & "$C$12" & Chr$(34) & "," & _
                                          Chr$(34) & "$C$13" & Chr$(34)                                 '2005/3/12
    End If
    str_macto = _
        "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & _
        vbNewLine & vbTab & "If Target.Value <> " & Chr$(34) & Chr$(34) & " Then" & _
        vbNewLine & vbTab & vbTab & "Select Case Target.Address" & _
        vbNewLine & vbTab & vbTab & vbTab & "Case " & target_address & _
        vbNewLine & vbTab & vbTab & vbTab & vbTab & "Cancel = True" & _
        vbNewLine & vbTab & vbTab & vbTab & vbTab & "Workbooks(" & Chr$(34) & ActiveWorkbook.Name & Chr$(34) & ").Activate" & _
        vbNewLine & vbTab & vbTab & vbTab & vbTab & "Sheets(" & Chr$(34) & ActiveSheet.Name & Chr$(34) & ").Select" & _
        vbNewLine & vbTab & vbTab & vbTab & vbTab & "Workbooks(" & Chr$(34) & ActiveWorkbook.Name & Chr$(34) & _
                                        ").Sheets(" & Chr$(34) & ActiveSheet.Name & Chr$(34) & ").Range(Target.Value).Select" & _
        vbNewLine & vbTab & vbTab & vbTab & "Case Else" & _
        vbNewLine & vbTab & vbTab & vbTab & vbTab & "DoEvents" & _
        vbNewLine & vbTab & vbTab & "End Select" & _
        vbNewLine & vbTab & "End If" & _
        vbNewLine & "End Sub"                                                                           '2005/3/12

    On Error GoTo resume_point

    If data_cnt = 0 Then                                            '2005/3/12
        response = MsgBox("セルの個数 = " & cells_cnt & vbCr & _
                          "データの個数 = " & data_cnt & vbCr, _
                          vbYes, "選択セルの情報")                  '2005/3/12
        Exit Sub                                                    '2005/3/12
    End If                                                          '2005/3/12

    cells_info = "セルの個数 = " & cells_cnt & vbCr & _
                 "データの個数 = " & data_cnt & vbCr & vbCr & _
                 "文字セルの個数 = " & data_cnt - numeric_cnt & vbCr & _
                 "数値セルの個数 = " & numeric_cnt & vbCr & vbCr    '2005/3/12

    If data_cnt - numeric_cnt > 0 Then                          '文字列のセルがある場合 2005/3/12
        cells_info = cells_info & "文字数合計 = " & char_cnt & vbCr & _
                                  "文字数最大値 = " & char_max & " [" & char_max_pos & "]" & vbCr & _
                                  "文字数最小値 = " & char_min & " [" & char_min_pos & "]" & vbCr & vbCr
    End If

    If numeric_cnt > 0 Then                                     '数値のセルがある場合 2005/3/12
        num_ave = num_sum / numeric_cnt
        If disp_format <> "" Then                               '選択開始セルが数値セルの場合 2005/3/12
            cells_info = cells_info & _
                         "数値最大値 = " & Format(num_max, disp_format) & _
                         " ( " & num_max & " ) [" & num_max_pos & "]" & vbCr & _
                         "数値最小値 = " & Format(num_min, disp_format) & _
                         " ( " & num_min & " ) [" & num_min_pos & "]" & vbCr & vbCr & _
                         "数値合計 = " & Format(num_sum, disp_format) & _
                         " ( " & num_sum & " )" & vbCr & _
                         "数値平均 = " & Format(num_ave, disp_format) & _
                         " ( " & num_ave & " )" & vbCr & vbCr
        Else
            cells_info = cells_info & _
                         "数値最大値 = " & num_max & " [" & num_max_pos & "]" & vbCr & _
                         "数値最小値 = " & num_min & " [" & num_min_pos & "]" & vbCr & vbCr & _
                         "数値合計 = " & num_sum & vbCr & _
                         "数値平均 = " & num_ave & vbCr & vbCr
        End If
    End If

    cells_info = cells_info & vbCr & "この情報を利用しますか？" & vbCr & vbCr    '2005/3/12
    response = MsgBox(cells_info, vbYesNo + vbInformation + vbDefaultButton2, "選択セルの情報") '2005/3/12
resume_point:

    If Err.Number = 6 Then
        MsgBox "セルと同じ表示形式ではオーバーフローで表示できないため、" & vbCr & _
               "標準書式で表示します"
        cells_info = cells_info & _
                     "数値最大値 = " & num_max & " [" & num_max_pos & "]" & vbCr & _
                     "数値最小値 = " & num_min & " [" & num_min_pos & "]" & vbCr & vbCr & _
                     "数値合計 = " & num_sum & vbCr & _
                     "数値平均 = " & num_ave & vbCr & vbCr
        response = MsgBox(cells_info, vbYesNo + vbInformation + vbDefaultButton2, "選択セルの情報")          '2005/3/12
    End If                                                                                      '2005/3/12

    If response = vbNo Then                                                                             '2004/10/9
        Exit Sub                                                                                        '2004/10/9
    End If                                                                                              '2004/10/9

    Set newbook = Workbooks.Add                             '新規Bookを開く
    newbook_name = newbook.Name                                                                         '2004/10/9
    Workbooks(newbook_name).Activate                                                                    '2004/10/9
    Sheets(1).Select                                                                                    '2004/10/9

    Cells(1, 1).Value = "選択範囲": Cells(1, 2).Value = selected_range_address                          '2004/10/9
    Range("B1").Font.ColorIndex = 5                                                                     '2005/3/12
    Cells(2, 1).Value = "セルの個数": Cells(2, 2).Value = cells_cnt                                     '2004/10/9
    Cells(3, 1).Value = "データの個数": Cells(3, 2).Value = data_cnt                                    '2004/10/9

    Cells(5, 1).Value = "文字セルの個数": Cells(5, 2).Value = data_cnt - numeric_cnt                    '2005/3/12
    Cells(6, 1).Value = "数値セルの個数": Cells(6, 2).Value = numeric_cnt                               '2005/3/12

    Cells(8, 1).Value = "文字数合計": Cells(8, 2).Value = char_cnt                                      '2005/3/12
    Cells(9, 1).Value = "文字数最大値": Cells(9, 2).Value = char_max                                    '2005/3/12
        If data_cnt - numeric_cnt > 0 Then Cells(9, 3).Value = char_max_pos                             '2005/3/12
    Cells(10, 1).Value = "文字数最小値": Cells(10, 2).Value = char_min                                  '2005/3/12
        If data_cnt - numeric_cnt > 0 Then Cells(10, 3).Value = char_min_pos                            '2005/3/12
    Range("C9:C10").Font.ColorIndex = 5                                                                 '2005/3/12

    Cells(12, 1).Value = "数値最大値"                                                                   '2005/3/12
    Cells(13, 1).Value = "数値最小値"                                                                   '2005/3/12
    Cells(15, 1).Value = "数値合計"                                                                     '2005/3/12
    Cells(16, 1).Value = "数値平均"                                                                     '2005/3/12

    If cell_format <> "" Then                                                                           '2005/3/12
        Cells(12, 2).Value = num_max                                                                    '2005/3/12
        Cells(12, 2).NumberFormatLocal = cell_format                                                    '2005/3/12
        Cells(12, 3).Value = num_max                                                                    '2005/3/12
        Cells(12, 4).Value = num_max_pos                                                                '2005/3/12
        Cells(13, 2).Value = num_min                                                                    '2005/3/12
        Cells(13, 2).NumberFormatLocal = cell_format                                                    '2005/3/12
        Cells(13, 3).Value = num_min                                                                    '2005/3/12
        Cells(13, 4).Value = num_min_pos                                                                '2005/3/12
        Cells(15, 2).Value = num_sum                                                                    '2005/3/12
        Cells(15, 2).NumberFormatLocal = cell_format                                                    '2005/3/12
        Cells(15, 3).Value = num_sum                                                                    '2005/3/12
        Cells(16, 2).Value = num_ave                                                                    '2005/3/12
        Cells(16, 2).NumberFormatLocal = cell_format                                                    '2005/3/12
        Cells(16, 3).Value = num_ave                                                                    '2005/3/12
        Range("D12:D13").Font.ColorIndex = 5                                                            '2005/3/12
     Else
        Cells(12, 2).Value = num_max                                                                    '2005/3/12
        Cells(12, 3).Value = num_max_pos                                                                '2005/3/12
        Cells(13, 2).Value = num_min                                                                    '2005/3/12
        Cells(13, 3).Value = num_min_pos                                                                '2005/3/12
        Cells(15, 2).Value = num_sum                                                                    '2005/3/12
        Cells(16, 2).Value = num_ave                                                                    '2005/3/12
        Range("C12:C13").Font.ColorIndex = 5                                                            '2005/3/12
    End If

    Columns("A:D").EntireColumn.AutoFit                                                                 '2005/3/12
    If Columns("B:B").Width > 200 Then Columns("B:B").ColumnWidth = 24.38                               '2005/3/12
    Range("A18").Value = "青字のセル番号をダブルクリックすると、そのセルにカーソルを移動させます"       '2005/3/12
    Range("A18").Font.ColorIndex = 5                                                                    '2005/3/12
    ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule.AddFromString str_macto                  '2005/3/12
    Windows.Arrange ArrangeStyle:=xlArrangeStyleHorizontal                                              '2005/3/12
'
End Sub
　 　

←目次へ戻る　/　このページのマクロ（テキスト）の表示

Back　Next

モーグ

Google
  Web excel7.com