2007-05-07 - Cassiopeiaの日記

2007-05-07 - Cassiopeiaの日記より
: "■[Excel VBA]Excelのコンテキストメニュー(右クリックメニュー)に独自のメニューを追加する。

■使用上の注意

RemoveCellMenu()で追加したメニューを削除しないと、どんどん同じメニューが追加されてしまいます。　あなたが実際に使うマクロを創るときには追加したメニューを自動的に削除してから終了するようにするなり、すでに独自メニューがあるときはさらに独自メニューを追加しないようなコードを追加してください。

'AddCellMenu()で独自のメニューをコンテキストメニュー
'(右クリックメニュー)に追加する。
'RemoveCellMenu()で追加したメニューを削除する。


Sub AddCellMenu()
Dim MyCellMenu As CommandBarControl

Application.CommandBars('Cell').Controls.Item('切り取り(&T)').BeginGroup = True
'区切り線を追加しています。

Set MyCellMenu_01 = CommandBars('Cell'). _
Controls.Add(Type:=msoControlButton, before:=1)

With MyCellMenu_01
.Caption = '電卓起動！'
.FaceId = 50
.OnAction = 'ExecCalc'
End With

Set MyCellMenu_02 = CommandBars('Cell'). _
Controls.Add(Type:=msoControlButton, before:=1)

With MyCellMenu_02
.Caption = '数字だったら２倍する！'
.FaceId = 102
.OnAction = 'NumW'
End With

End Sub

Sub RemoveCellMenu()
CommandBars('Cell').Controls.Item('電卓起動！').Delete
CommandBars('Cell').Controls.Item('数字だったら２倍する！').Delete
CommandBars('Cell').Controls('切り取り(&T)').BeginGroup = False
End Sub

Sub ExecCalc()
Shell 'calc'
End Sub

Sub NumW()
If IsNumeric(ActiveCell.Value) Then
ActiveCell.Value = ActiveCell.Value * 2
Else
'zzz...
End If
End Sub"

セル右クリックメニュー

次のプロシージャは、セルのコンテキストメニューを追加するものである。セルの右クリックから［売上データ読み込み］を選択したとき、「Proc_Uriage1」プロシージャが実行されるように、コマンドを割り当てたい。

Sub Sample()
　　　With Application.CommandBars("Cell").Controls.Add
　　　　　　.Caption = "売上データ読み込み"
　　　　　　.OnAction= "Proc_Uriage1"
　　　　　　.Visible = True
　　　End With
End Sub

プロジェクトのコピー

プロジェクトのコピー: "ソリューション エクスプローラで Web プロジェクトをコピーするには

1. ソリューション エクスプローラで、コピーする Web プロジェクトを選択します。
2. [プロジェクト] メニューの [プロジェクトのコピー] をクリックします。
3. コピー先の Web サーバーと新しい URL を指定します。"

EXCEL マージしたセルの行の高さ調整

行・列の結合具合に関係なく矩形選択したセルの中に全部の入力値が表示できるよう行高を調整します。
やってることは、単一セルにしてしまい、最適な行高を調べ、それを選択した行の高さに配分し再度結合を行っています。列の結合を行っている場合は、フォントの具合が微妙で、１行分余分になってしまうことがあります。現時点では回避できていません。（たまに起きます）
nmHgt = ActiveSheet.StandardHeight　でシートに設定された標準の高さを使っていますが、直接数値を入れても（例えば13.5とか、そのシートの固有な高さ）いいです。
標準モジュールに貼り付けて、ツール→マクロ→マクロ→オプションでZとかのキーを割り当てると、調整したいセル範囲を選択し、Ctrl+Shift+Zキーでマクロが動きます。

参考になればと思い作って見ました。（行数を減らすためにかなりもがいています。マルチステートメントをばらしてインデントをつければ見やすくなると思います）

Public cWd() As Single '選択範囲の各列の幅

Public Sub AutoFitEx()
Dim nmHgt As Single '標準行高
nmHgt = ActiveSheet.StandardHeight '値をセットしてもいい
Dim rg As Range '選択セル範囲
Dim intHgt, fitHgt As Single '初期の行高、調整した行高
Dim mgRCt, mgCCt As Single '結合された行数、列数
Dim rCt, cCt As Integer '行・列カウンタ
Dim wkHgt, dsHgt As Single '必要な行高、計算上の行高
Application.ScreenUpdating = False
Set rg = Selection
'=== 結合解除 ===
mgRCt = rg.Rows.Count: mgCCt = rg.Columns.Count
If mgRCt > 100 Then Exit Sub '余り多数の行・列を選択したら処理しない
ReDim cWd(mgCCt)
For cCt = 1 To mgCCt '各列の幅を読み込む
cWd(cCt) = rg.Cells(1, cCt).ColumnWidth
cWd(0) = cWd(0) + cWd(cCt)
Next
rg.Select: rg.HorizontalAlignment = xlLeft: rg.VerticalAlignment = xlTop
rg.MergeCells = False
'=== １セルに収めて必要な高さを知る ===
rg.Cells(1, 1).Select: intHgt = nmHgt
With Selection
.ColumnWidth = cWd(0): .WrapText = True: .Rows.AutoFit: fitHgt = .Height
End With
'=== 必要な高さを各行に等分する ===
If fitHgt / intHgt > mgRCt Then
For rCt = 1 To mgRCt
wkHgt = fitHgt * 100
dsHgt = (Int(wkHgt / (75 * mgRCt)) - (wkHgt Mod (75 * mgRCt) <> 0)) * 0.75
rg.Cells(rCt, 1).RowHeight = dsHgt
Next
Else
For rCt = 1 To mgRCt: rg.Cells(rCt, 1).RowHeight = nmHgt: Next
End If
'=== 列の幅を元に戻し結合する ===
For cCt = 1 To mgCCt: rg.Cells(1, cCt).ColumnWidth = cWd(cCt): Next
rg.MergeCells = True '再度結合する
Application.ScreenUpdating = True
End Sub