OfficeBooleはExcel(エクセル)VBAでみなさまのお仕事をサポートします
office boole logochoro
代 表 : Office Boole 末永尚登
E-mail : suenaga@officeboole.com
TEL / FAX   : 095-893-6090
携 帯 : 070-4087-0025



title

(さあ困った、どうしよう?というときどうぞ)
VBA編 一定間隔での行挿入を一括実行したいとき
空白行を一括で削除したいとき
処理の速度を上げたいとき(画面更新の抑制)
コーディングの誤りを見つけたいとき(デバッグ)
乱数を取得したいとき
セルの値を分割して別の各セルへ配置したいとき
テキストファイルに書いたコードを標準モジュールに挿入したいとき
処理確認のメッセージを出したくないとき(警告メッセージの抑制)
同じフォルダにある別のBookを開きたいとき
集計の処理速度を上げたいとき
「開く」ダイログを使ってファイル名を取得したいとき
任意の数の引数を受け取る関数を作成したいとき
処理速度を上げるため、一時的に再計算を止めたいとき
右クリックメニューにマクロを登録したいとき
1行目を除いた範囲を選択したいとき
データの最後の行番号を取得したいとき
ツールバーに自作のマクロを登録したいとき
全セルを調整、初期化したいとき
可視セルのみをコピー&ペーストしたいとき
テキストボックスで数値以外のキーを受け付けないようにしたいとき
ある範囲の中での相対的位置を指定したいとき
グラフの元データを任意に変更したいとき
メニューバーに自作のマクロを登録したいとき
テキストファイルに書き出したいとき(FSO編)
ファイルを削除したいとき
ファイルを削除したいとき(FSO編)
SendKeysステートメントで他キーとの組み合わせを指定したいとき
クリックしたオブジェクト名を取得したいとき
論理値を反転させたいとき
クリックした行に色を付けたいとき
ワークシート上のすべてのオブジェクト名を調べたいとき
ユーザーフォームの「×」ボタンを無効にしたいとき
計算式の中で文字列を引用符で囲みたいとき
グラフサイズを統一したいとき
1つのシートだけのブックを新たに作成したいとき
範囲名を自動で付けたいとき
Changeイベントで特定セルを判定したいとき
自動リンクの更新メッセージを表示させないようにしたいとき
特定のセルのみ選択できるようにしたいとき
シート上のコマンドボタンから他シートを操作したいとき
Excelのバージョンを調べたいとき
ブックのショートカットを作成したいとき
新規ブックに名前を付けて保存したいとき
マクロモジュールを他のブックへコピーしたいとき
標準モジュールを解放(削除)したいとき
パスからファイル名のみを取り出したいとき
現在開いているブックの一覧を取得したいとき
メニューバーの一部を無効にしたいとき
ユーザフォームに動的にコマンドボタンを追加したいとき
フォルダ参照ダイアログボックスを表示させたいとき
マクロ名を表示させたくないとき
ロックがかかっていないセルを調べたいとき
リストボックスを複数列にして見出しを付けたいとき
マクロを一定時間停止させたいとき
メニューにチェックマークをつけたいとき
Excelの「×」ボタンを無効にしたいとき
ブック内のハイパーリンクアドレスをすべて抽出したいとき
メッセージを表示させないでブックを閉じたいとき
右クリック時にショ−トカットメニュ−を表示させたくないとき

Excel編へ

●一定間隔での行挿入を一括実行したいとき

この処理を行わせるにはVBAによるコーディングが、わずかですが必要になります。つまり行挿入を自動実行させるわけです。
ここではデータが縦に複数行入力されている場合に、あとから6行ごとに1行の空欄を挿入する場合(1行目には見出し項目があるとする)で説明します。

まずExcelにコードを書き込むために、次の手順でコードウィンドウを開きます。
1)左手で「Alt」キーを押した状態で、右手でキーボード右斜め上の「F11」キーを押します。
2)するとVisual Basic Editorが起動してExcelとは別の画面が表示されます。
3)上部のメニューバーから「挿入」→「標準モジュール」と選択して、「Module1」というコードを書き込むための領域を表示させます。
4)同様に上部のメニューバーから「挿入」→「プロシージャ」と選択して、これから記述するコードのかたまりに名前を付けます。
5)どんな名前でもよいですから適当な名前をプロシージャ名として登録します。その際半角文字でも全角文字でもかまいません。覚えやすい名前を付けて下さい。
6)それが終わったらそのままOKボタンを押してウィンドウを閉じます。するとPublic Sub xxx( )からEnd Subまでの空欄が自動的に作成されます。
7)そうしたらこの間の領域に以下のコードを記入します。

Do While ActiveCell.Offset(7, 0).Value <> ""
  ActiveCell.Offset(7, 0).Rows("1:1").EntireRow.Select
  Selection.Insert Shift:=xlDown
Loop


8)記入が終わったら、画面左上にExcelのアイコンボタンがありますので、それを押してExcelの画面に戻ります。
9)1行目から行数をカウントさせるために、セルのA1を予めクリックして選択しておきます。
10)上部のメニューバーから「ツール」→「マクロ」→「マクロ」と選択して、コードを実行するウィンドウを開きます。
11)さきほど名前を付けたコードをリストから選択して、実行ボタンを押します。
12)すると自動的に6行おきに空欄が挿入されていき、データが切れたところで終了します。

【解説】
「Do While ActiveCell.Offset(7, 0).Value <> ""」と「Loop」は繰り返し同じ動作を実行させる時必要となる命令です。繰り返しを終わらせる条件として、「現在挿入を実行している行から7番目下方のA列のセルにデータが入ってない状態になるまで処理を繰り返せ」という意味になります。
ActiveCell.Offset(7, 0).Rows("1:1").EntireRow.Selectは現在処理中の行から7番目下方の行を1行まるごと選択させる命令です。
Selection.Insert Shift:=xlDownで行の挿入を行わせています。

実のところ、行の選択と挿入の命令は特に知らなくても、「マクロ記録」という機能を使えば実際にワークシート上でやらせたい操作を行い、それを自動記録させることでコードを確認することができます。
プログラミングの知識が必要な部分は同じ処理を繰り返し行わせる部分だけですので、書店などでVBAの関連図書を覗いてみてください。
今はVBAについて詳しく説明された本が多数出ていますので、自分のレベルにあったものを探すことが出来ればすぐに理解できるでしょう。
興味のある方は勉強してみてください。

●空白行を一括で削除したいとき

複数行にデータが入力されているとき、途中の空白行のみを削除したいときがあります。
数が少なければ一つ一つ手作業で削除していってもたいしたことはありませんが、件数が1000件を超えるような作業だと かなりの手間となってしまいます。
こんなとき10行程度のVBAコードを書くことで、大幅に作業時間を短縮させることが出来ます。
ここではA列に飛び飛びにデータが入力されているものとします。
まず「Alt」+「F11」でVBEを起動し標準モジュールを挿入した上で、以下のコードを記入してください。プロシージャの名前は任意に決めてもらって結構です。

Sub sakujo()
Dim i As Long
Dim y As Long

Cells(65536, 1).Select
Selection.End(xlUp).Select
y = ActiveCell.Row

For i = y To 1 Step -1
   If Cells(i, 1) = "" Then
      Cells(i, 1).Delete Shift:=xlUp
   End If
Next
End Sub

1)変数iとyを宣言します。Integer型だと32767の数までしか扱えないので、念のためLong型にします。
2)Cells(65536, 1).SelectでA列の一番最後の行にポインタを位置づけます。
3)Selection.End(xlUp).Selectでデータの最後の位置を探します。
4)y = ActiveCell.Rowでデータ最後部の行番号を取得します。
5)次にFor〜Next文で、データの最後の行から順番に空白行を調べていき、空白があれば削除します。
6)削除後は行を上の方に詰めていって、これを先頭行までくり返します。
このコードを記述したあと、Excelの画面にもどりメニューバーから「ツール」→「マクロ」→「マクロ」でプロシージャ名を選択して実行ボタンを押すと、コードが実行されます。

●処理の速度を上げたいとき(画面更新の抑制)

データの並べ替えや抽出などを行うとき、画面がちらついたり処理の実行過程がすべて見えてしまうことがあります。 そのため処理のスピードも落ちてしまいます。
そんなとき次のコードを処理の先頭に入れておくと、結果のみが画面に表示されることになり、速度も向上します。

Application.ScreenUpdating=False '画面更新の抑制

処理が終わったら必ず処理の最後に次のコードも入れてください。

Application.ScreenUpdating=True '抑制の解除

●コーディングの誤りを見つけたいとき(デバッグ)

VBAでコードを記述して実行をして見ると、思った通りの動作にならないことがよくあります。
論理エラーと呼ばれるもので、処理のアルゴリズム(問題解決手順)に誤りがある場合に発生します。
文法エラーの場合はコードを記述した時点で、システムが教えてくれることが多いのですが、論理エラーは自分で探し、解決するしかありません。
短いコードであれば、うまく動作しない部分をよく見て処理の動きを追いかけることで、すぐに見つかる場合が多いのですが、長いプログラムや短くても内部の処理がわからない場合は、 誤りを見つけるのに非常に苦労します。

そんなときデバッグの方法をいくつか知っていると、とても重宝します。
1つはブレークポイントを活用することです。ブレークポイントはプログラムの実行途中で処理を止めて、その時点での動作結果を確認する場合に使います。
VBAエディタが開いている画面で、調べたいコード上にカーソルを置き、メニューバーの「デバッグ」→「ブレークポイントの設定/解除」で行えます。(直接コードウィンドウの左端をクリックしても行えます)
この状態でコードを実行すると、必ずブレークポイントを設定した場所でいったん処理がストップするので、止まったら変数の内容を調べたり(カーソルを変数の上に置くと、内容が表示されます)、画面上の結果を確認したり出来ます。

2つめはイミディエイトウィンドウを利用することです。
イミディエイトウィンドウはメニューバーの「表示」→「イミディエイトウィンドウ」で表示させることができます。このウィンドウに変数の内容等の履歴を書き出すことができるので、内部のデータの変化を連続して確認する時に重宝します。
イミディエイトウィンドウに出力する方法は、通常Debug.Print 変数名という書き方で、この命令をコードの好きな場所に埋め込みます。コードを実行した時に、この命令が実行されると、変数の中身がイミディエイトウィンドウに書き出されますので、実行途中や実行後に確認することが出来ます。

次の例はDo While のループ処理で、ループ1回ごとに変数c,i,jの内容をイミディエイトウィンドウに書き出しています。

c = 0
Randomize
Do While c < 30
    i = Int(Rnd * 10 + 3)
    j = Int(Rnd * 9 + 2)
    With Cells(i, j)
        If .Value <> "★" Then
             .Value = "★"
             .Font.ColorIndex = 34
            c = c + 1
            Debug.Print c, i, j          'デバッグ箇所
        End If
    End With
Loop
		

●乱数を取得したいとき

ゲームなどでランダムな数を発生させ、それを利用したいと思ったことはありませんか?
VBAでは乱数を発生させる関数(Rnd関数)があり、これを利用すれば簡単に乱数を取り出すことが出来ます。

書式は「C = Int((Rnd * B) + A)」となります。
Cは任意の変数で、あらかじめ整数型でプロシージャの先頭で宣言しておきます。
A、Bはなくてもよいのですが、必要なときに数値を指定します。
Rnd命令で0より大きく1より小さい数がランダムに取り出せます。この数を直接利用してもかまいませんが、通常は0から9までの任意の数だとか 1から99までの任意の数だとか整数型で利用する場合が多いと思います。

そんなときInt()関数を用いて小数点以下の数を整数に変換します。0から9までの整数であれば、「変数=Int(Rnd*10)」となります。
今の数を1だけシフトさせたければ「変数=Int((Rnd*10)+1)」とします。これで1から10までの数が取り出せます。
しかし困ったことに、この乱数もRnd命令を記述したプロシージャを毎回呼び出すと、決まったパターンの数値が現れてしまうことがあります。
そこでRnd命令の前にRandomizeステートメントを置くことで、同一パターンの発生を防ぐことが出来ます。

Randomize
kazu=Int((Rnd*10)+1)

これは実行時の時刻をもとにして、乱数計算のシードを変化させることで実現しています。

●セルの値を分割して別の各セルへ配置したいとき

1つのセルに生年月日や住所などが入っており、それを別々のセルへ分割して格納したいときがあります。
そういう場合はSplit関数を知っていると便利です。

※年月日は先頭にシングルクォーテーション(')をつけて文字列にしてあります Excelサンプル

Split関数は、区切られた文字列から配列を作成して結果を返す関数です。
書式はSplit(対象文字列,区切り文字)となります。
区切り文字はダブルクォーテーション("")で囲みます。

サンプルを2つ挙げておきます。どちらも動作はまったく一緒です。

Excelサンプル

データが大量にある場合に威力を発揮します。ぜひ試してみてください。

●テキストファイルに書いたコードを標準モジュールに挿入したいとき

テキストファイルの内容を標準モジュールに挿入することができます。
1)モジュールを開き、テキストファイルを挿入したい位置にカーソルを置きます。
2)メニューバーから「挿入」→「ファイル」→「テキストファイルの読み込み」ダイアログボックスでファイル名を選択し、「開く」ボタンを押します。
3)テキストファイルの内容(コード)がインポートされます。

●処理確認のメッセージを出したくないとき(警告メッセージの抑制)

Worksheetを削除したり、内容を更新してBookを閉じたりするときには必ずシステムの方から確認のメッセージが 表示されます。
これがわずらわしかったり不必要と思う場面では、メッセージを出させないようにすることもできます。
処理の前に次のコードを入れてください。

Application.DisplayAlerts=False '警告メッセージの抑制

処理が終わったら念のため処理の最後に次のコードも入れてください。

Application.DisplayAlerts=True '抑制の解除

●同じフォルダにある別のBookを開きたいとき

プロシージャの処理の途中で別のBookを開いて内容を参照したいときがある場合はWorkbooks.Open命令を使います。

書式はWorkbooks.Open Filename:="ファイル名"となっていますが、単純にファイル名だけを指定しても「○○○が見つかりません。 ファイル名およびファイルの保存場所が正しいかどうか確認してください。」というメッセージが返ってきてしまいます。

これはそのまま指定すると、システムはExcelそのものがインストールされている場所を探しに行くためで、カレントディレクトリがWorkbookが保存されてる場所と異なるために発生します。

したがって目的のファイルを開くには、まず開きたいWorkbookのパスを取得する必要があります。
ここではVBAがかかれているBookと今から開こうとしているBookが同じフォルダに存在する場合のコーディング例を示します。

Dim fName As String
Dim book As Workbook

Set book = Application.ActiveWorkbook

'現在のPathとファイル名を連結
fName = book.Path & "\○○○.xls"

'目的のファイルを開く
Workbooks.Open Filename:=fName

ここでファイル名の前に¥を付けることを忘れないでください。

●集計の処理速度を上げたいとき

データ数が多くて、集計処理に時間がかかるとき、例えばFOR〜NEXT文などで処理をループさせている場合は 結果が出るまでにかなり時間がかかってしまう場合があります。
そのようなとき、Excelに備わっているワークシート関数を利用することで、思わぬ速度向上が実現できる場合があります。

処理をループさせて計算している例
Public Sub plus1()

    Dim c As Range
    Dim tmp As Long
    
    tmp = 0
    For Each c In Range("A1:A10000")
        tmp = tmp + c.Value
    Next c
    
    Cells(1, 2).Value = tmp
    
End Sub


ワークシート関数のSUM関数を利用している例
Public Sub plus2()

    Dim tmp As Long
    
    tmp = Application.Sum(Range("A1:A10000"))
    Cells(1, 3).Value = tmp
    
End Sub


このようにプログラム中にワークシート関数が利用できる場合は、既存の関数に計算を任せたほうが正確で安全に処理を行わせることできます。
ただしこの程度のサンプルコードでは大して差はありません。もっと良い例をお見せできればよかったんですが・・・。

●「開く」ダイログを使ってファイル名を取得したいとき

たいていのアプリケーションが利用している、ファイルを開く際のダイアログボックスを利用して、ファイル名を取得する場合はGetOpenFilename() メソッドを使うことで実現できます。
以下はテキストファイル名(パス情報)を取得し、従来のOpen命令でファイルを開いて処理する例をあげています。
なお、キャンセルボタンが押されたときの処理も記述しておかないと、「開く」「キャンセル」どちらのボタンが押されても以下の処理が実行されてしまいます。

Public Sub ReadText()

    Dim FileNumber As Integer
    Dim TextLine As String
    Dim myFile As String
    Dim i As Integer
    
    '「ファイルを開く」ダイアログ表示
    myFile = Application.GetOpenFilename("テキストファイル,*.txt")
    
    'キャンセルボタンが押されたとき
    If StrConv(myFile, vbUpperCase) = "FALSE" Then
        MsgBox "キャンセルされました。"
        Exit Sub
    End If
    
    'テキストファイルを入力モードでOPEN
    FileNumber = FreeFile
    Open myFile For Input Access Read As #FileNumber
    
    'テキストデータをA列へ順に格納
    i = 1
    Do While Not EOF(FileNumber)
        Line Input #FileNumber, TextLine
        Cells(i, 1).Value = TextLine
        i = i + 1
    Loop
    
    Close #FileNumber
    
End Sub

Public Function CallOpenDialogue() As String
'Function関数の戻り値として取得

    Dim myFile As String
    Dim FileType As String
    Dim Title As String
    
    FileType = "画像ファイル,*.jpg;*.gif;*.bmp"
    Title = "画像ファイルを選択してください。"
    myFile = Application.GetOpenFilename(FileType, , Title)
    If StrConv(myFile, vbUpperCase) = "FALSE" Then
        Title = "「ファイルを開く」操作をキャンセル"
        MsgBox "キャンセルされました。", vbInformation, Title
        Exit Function
    End If
    CallOpenDialogue = myFile

End Function
		


●任意の数の引数を受け取る関数を作成したいとき

引数の数が不定の場合は、引数はParamArrayキーワードを使い、Variant型で作成します。 (逆に言うとVariant型でしか宣言できません)
したがってデータ型の宣言を省略すると自動的にVariant型になるので、あえて型を指定しないで宣言します。
次のサンプルはSUM()関数と同様に、離れた場所に点在する数値の合計をセル番地を引数として指定し、その合計を返します。

test関数を使用する際に引数を指定しますが、その際にカンマで区切るとそのひとつひとつがaa配列の各要素となります。
各要素を分離するために、まずFor Eachステートメントを使ってbbに各要素の内容を取り出します。
次に、取り出されたbbはあるセル範囲を表している可能性がありますので、さらにFor Eachを使って個々のセルに分離します。
したがって変数ccはオブジェクト型(Range)で宣言しておきます。
あとはValueプロパティを使ってセルの値を取り出し、累計を計算する式に当てはめれば完成です。

Public Function test(ParamArray aa()) As Currency

    Dim gk As Currency
    Dim bb As Variant
    Dim cc As Range
    
    For Each bb In aa
        For Each cc In bb
            gk = gk + cc.Value
        Next
    Next

    test = gk

End Function
		


●処理速度を上げるため、一時的に再計算を止めたいとき

セルの値を何度も更新するような処理をさせる場合に、処理の途中で再計算機能が実行され、実行速度に大きな影響が及ぶことがあります。
このようなときは一時的にExcelの再計算機能をオフにして処理を進め、最後に再計算させることで速度アップを図ることができます。

'再計算を「手動」にする
Application.Calculation = xlManual

'セルに数値を入力する
Range("A1").Value = 123
Range("A2").Value = 456
Range("A3").Value = 789

'再計算を「自動」に戻す
Application.Calculation = xlAutomatic
		


上のようなプロシージャでは、再計算機能を止めなければ、A4にSUM関数( =SUM(A1:A3) )が入力されている場合、3回もSUM関数が実行されてしまいます。

●右クリックメニューにマクロを登録したいとき

セルを選択している状態で、右クリックしたとき表示されるショートカットメニューから自作のマクロを実行させたいときがあります。この場合はあらかじめメニュー追加のコードを用意しておきます。
まずVBエディタで標準モジュールを挿入し、そこへメニュー追加のサブプロシージャを作成します。
サンプルではRightClickプロシージャでメニュー追加の処理をさせています。
後はこのプロシージャを操作の前に実行すれば、いつでも自作のマクロを呼び出すことができます。
ただこのままですと、このワークブックを閉じた後もショートカットメニューにマクロ名が残りっぱなしになってしまいますので、終了時に必ずメニュー登録解除のプロシージャを実行しておく必要があります。
サンプルではMenuResetプロシージャがそれに該当します。



Public Sub MsgOut1()
    MsgBox "メッセージ-1が呼び出されました。"
End Sub

Public Sub MsgOut2()
    MsgBox "メッセージ-2が呼び出されました。"
End Sub

Public Sub RightClick()
'右クリックメニューに項目を追加

    Dim myRight As CommandBar
    
    '右クリックメニューをオブジェクト変数に代入
    Set myRight = Application.CommandBars("Cell")
    
    '右クリックメニューにメニュー追加
    With myRight
    '1番目に追加
        .Controls.Add Type:=msoControlButton, Before:=1
        .Controls(1).Caption = "メッセージ-1"
        .Controls(1).OnAction = "MsgOut1"
    '2番目に追加
        .Controls.Add Type:=msoControlButton, Before:=2
        .Controls(2).Caption = "メッセージ-2"
        .Controls(2).OnAction = "MsgOut2"
    End With

End Sub

Public Sub MenuReset()
'右クリックメニューをリセット

    Application.CommandBars("Cell").Reset

End Sub
		

●1行目を除いた範囲を選択したいとき

1行目が見出しのため、1行目を除いたデータが格納されている全範囲を選択したいときがあります。
そのような場合はいったん全範囲を選択した後、OffsetプロパティとResizeプロパティを使って選択範囲を調整します。

Range("A1").CurrentRegion.Select
Selection.Offset(1).Resize(Selection.Rows.Count - 1).Select
Selection.ClearContents

上記ではA1以下にデータが存在する場合です。
Offset(1)はOffset(1,0)と同じ意味です。現在位置より下方へ1行下がります。
Resize変更したセル範囲の「Rangeオブジェクト」を再取得するプロパティです。

●データの最後の行番号を取得したいとき

A列データの最後の行番号を取得する場合は、ワークシートの最終行から上方向に検索します。
ワークシートのMAX行は65536行なので、その位置から「End」キーを押した状態で「↑」キーを押す操作を記述します。

Dim r As Long
r = Range("A65536").End(xlUp).Row

これで変数rに、A列のデータ最後尾の行番号が格納されます。

特定の列の最後のデータを調べるには上記の方法でよいですが、住所録など1件のデータが複数の列で構成されている場合、検査する列(例えばA列)がたまたま空白であった場合はうまくいきません。
このような場合はUsedRangeプロパティを利用して、データが格納されている範囲のアドレスから最後の行番号を得ることも可能です。
Dim adr As String
Dim pos As Integer
Dim r As Long
adr = ActiveSheet.UsedRange.Address
pos = InStrRev(adr, "$")
r = Val(Right(adr, Len(adr) - pos))

変数adrには絶対番地で、"$A$1:$D$10"のようなデータが格納されている範囲のアドレスが入ります。
このアドレスから終わりの行番号だけを求めています。
ただしセルに何も値が入ってないように見えても、書式設定などがしてあるとそれも使用領域の一部にみなされますので注意してください。

●ツールバーに自作のマクロを登録したいとき

いちいちメニューバーから「ツール」→「マクロ」→「マクロ」で呼び出すのは、何度も行わなければいけないマクロの場合は大変不便ですね。
Alt + F8でも同様のことはできますが、それでも3ステップの動作が必要です。
そこで自作マクロをメニューバーに登録することにより、1回の動作でマクロを実行させることが可能になります。
ツールバーにはキャプションとアイコンの両方を登録できるので、うまく利用すれば非常に分かりやすいボタンを作成できます。
FaceIdプロパティでWindowsに登録されているアイコンを番号で指定してください。
'マクロツールバーを作成します。
Public Sub OriginalBar()

    Dim myCB As CommandBar
    Dim myCBCtrl As CommandBarButton
    
    Set myCB = CommandBars.Add(Name:="MainMenu", temporary:=True)
    
    'First Button
    Set myCBCtrl = myCB.Controls.Add(Type:=msoControlButton)
    With myCBCtrl
        .Caption = "マクロの説明"
        .FaceId = 92    'アイコン
        .OnAction = "マクロの名前"
    End With
    
    
    'Display Tool Bar
    With Application.CommandBars("MainMenu")
        .Visible = True
        .Position = msoBarTop
    End With

End Sub

'ThisWorkBookのWorkbook_Openイベントで呼び出します。
Private Sub Workbook_Open()
    'マクロツールバーの作成
    OriginalBar
End Sub

'ThisWorkBookのWorkbook_BeforeCloseイベントで削除します。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'マクロツールバーの削除
    On Error Resume Next
        Application.CommandBars("MainMenu").Delete
    On Error GoTo 0

End Sub

		

●全セルを調整、初期化したいとき

シート全体の書式と値を消去します
Cells.Clear

シート全体の列幅を、入力された文字列の長さに合わせて調整します
Cells.EntireColumn.AutoFit

●可視セルのみをコピー&ペーストしたいとき

コピー対象の範囲に非表示の行列が含まれる場合、そのままでコピーを実行すると非表示部分のセルも一緒にコピーされてしまいます。
このようなときはメニューバーから「編集」→「ジャンプ」→「セル選択」→「選択オプション」ダイアログの可視セルを選択した状態にしてコピーをおこないますが、 同様の操作をVBAでコーディングすることで実現できます。

Range("A1").CurrentRegion.Select
'可視セルのみをコピー
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets("Sheet2").Select
ActiveSheet.Paste

Application.CutCopyMode = False

●テキストボックスで数値以外のキーを受け付けないようにしたいとき

シートまたはユーザーフォームにテキストボックスを貼付け、 KeyPressイベントを選択して、その中に以下のコードを記述します。
キー押し下げ時に、どのキーが押されたかを判定し、0〜9以外だったら 内容をクリアしてビープ音を鳴らします。

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

   If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
     KeyAscii = 0
     Beep
   End if

End Sub

●ある範囲の中での相対的位置を指定したいとき

表やテーブルなどを作成し、その中での相対的な位置を指定して何かをさせたい場合はありませんか?
Offset以外にもRangeとCellsを組み合わせて記述することで同様のことができます。



(A) そのまま指定すると、文字"A"がA1〜E4まで入力されます

Range(Cells(1, 1), Cells(4, 5)).Value = "A"

(B) Rangeオブジェクトで範囲を設定した上で指定すると、
C6からの相対的な位置(C6〜G9)に文字"B"が入力されます

Dim Test As Range
Set Test = Range("C6:G9")
Test.Range(Cells(1, 1), Cells(4, 5)).Value = "B"

●グラフの元データを任意に変更したいとき

グラフの元データを別なデータに、任意に差替えたいときはどうしたらよいでしょうか?
この場合、現在描画しようとしているグラフActiveChartのSetSourceDataメソッドで、データ範囲を指定することができます。
PlotBy引数を指定することにより、任意の方向をデータ系列としてグラフを作成することもできます。
引数PlotByは必要に応じて指定してください。列方向はPlotBy:=xlColumnsとします。行方向PlotBy:=xlRowsは省略可能です。
省略した場合には、データの形状に応じて自動的に判断されるようです。



Public Sub test1()
  ActiveSheet.ChartObjects("グラフ 1").Activate
  ActiveChart.SetSourceData Source:=Range("A1:D4"), PlotBy:=xlRows
End Sub

Public Sub test2()
  ActiveSheet.ChartObjects("グラフ 1").Activate
  ActiveChart.SetSourceData Source:=Range("A8:D11"), PlotBy:=xlRows
End Sub

●メニューバーに自作のマクロを登録したいとき

通常のメニューバーの最後に追加する場合(ヘルプの右横)を紹介します。

Public Sub AddMenuBar()

  'ワークシート上のメニューバーを定義
  Const MenuType = "Worksheet Menu Bar"
  '追加するメニューを定義
  Dim MainMenu As CommandBarControl
  'メニューの追加(最後へ)
  Set MainMenu = CommandBars(MenuType).Controls.Add _
    (Type:=msoControlPopup, Temporary:=True)
  'メニューの名前
  MainMenu.Caption = "自作マクロ呼び出し(&M)"
  'メニュー呼び出しプロシージャの設定
  MainMenu.OnAction = "CallMyMacro"

End Sub

●テキストファイルに書き出したいとき(FSO編)

ちょっと一時的にテキストファイルに書き込みたいとき、ファイルシステムオブジェクト(FSO)を使った、次のコードが便利です。
まずCreateObject関数でFileSystemObjectであるFSOを作成します。
そしてテキストファイルを開きます。
下の例ではOpenTextFileメソッドで、ファイルを開くモード(ioMode)に2を指定して、上書きモードで開いています。
モードには1:読取専用、2:上書き、8:追記モードがあります。
また3番目の引数は、ファイルが存在しない場合の指定で、True:存在しない場合新規作成する、False:新規作成しない(規定値)となっています。
次にWriteLineメソッドで1 行の文字列をテキストファイルに書き込みます。
最後にCloseメソッドでバッファをフラッシュしファイルを閉じます。
既に同名のファイルが存在する場合は、上書きされて以前のデータは消えてしまいますので注意してください。
なお1番目のファイルのパス以外は、すべて省略可能です。

Public Sub OutputText()

  Dim FSO
  Dim OSB
  Dim strPath As String

  Set FSO = CreateObject("Scripting.FileSystemObject")
  strPath = "C:\フォルダ名"
  strPath = strPath & "\" & "temp.txt"

  '上書きモードで開きます(ファイルが存在しなければ新規作成)
  Set OSB = FSO.OpenTextFile(strPath, 2,True)

  '文字を書き込む
  OSB.WriteLine "ABCDEFG"
  OSB.Close

  Set FSO = Nothing
  Set OSB = Nothing

End Sub

●ファイルを削除したいとき

ファイルを削除する場合の例です。
ここでは従来のBisualBasicのコマンド”Kill”を使っています。
削除しようとするファイルが見つからなかった場合の対応として、”On Error Resume Next”でエラーを無視して次のコードへ進んでいます。

Public Sub DeleteFile()

  Dim myPath As String

  myPath = ThisWorkbook.Path & "\" & "test1.txt"

  On Error Resume Next
  Kill myPath
  On Error GoTo 0

End Sub

●ファイルを削除したいとき(FSO編)

FSOを使ったファイルを削除する場合の例です。
Deleteメソッドを使っています。

Public Sub DeleteFile2()

  Dim FSO
  Dim myPath As String

  myPath = ThisWorkbook.Path & "\" & "test2.txt"
  Set FSO = CreateObject("Scripting.FileSystemObject")

  On Error Resume Next
  FSO.GetFile(myPath).Delete
  On Error GoTo 0

  Set FSO = Nothing

End Sub

●SendKeysステートメントで他キーとの組み合わせを指定したいとき

Shiftキー、Ctrlキー、Altキーと他のキーとの組み合わせを指定するには、通常のキーコードの前に次の記号を付加します。

  Shift : +
  Ctrl : ^
  Alt : %

  【例】
  Altキーを押しながらF11キーを押す → SendKeys "%{F11}",True


転送するキーコード(文字列式)は、必ず""で囲みます。
キーコードの転送によって実行される処理が終了するまで、次の動作を一時ストップしておきたい場合は、カンマで区切ってTrueを指定します。
何も指定しなければFalseと見なし、処理の終了を待たずに次の行に制御を移します。

●クリックしたオブジェクト名を取得したいとき

ワークシートにいくつかのオートシェイプが置いてあり、それをクリックしたときに、そのオブジェクトに色をつける例で説明します。
どのオブジェクトをクリックした場合も、同じプロシージャが呼び出されるようにし、そのプロシージャで、どのオブジェクトから呼び出されたかが分かるようにすれば、簡潔なマクロが組めそうですね。
この例では分かりやすいようにプロシージャを2つに分けて、objColorプロシージャで呼び出し元のオブジェクトを判別し、取得したオブジェクト名をFormatColorRedBlueプロシージャに引数として渡してあげて、そこで色を変更するようにしています。

ところでオートシェイプにマクロを登録する方法は、ワークシートに配置したオートシェイプ上で右クリックし、ポップアップメニューから「マクロの登録」を選択します。マクロの一覧からobjColorプロシージャを指定して「OK」ボタンを押せば、マクロが登録されます。
ではマクロを登録したら、試してみましょう。任意のオートシェイプを一度クリックすると、そのオートシェイプの色が変わり、もう一度クリックすると、元の色に戻りますね。

ここで重要なのはApplication.Callerプロパティを利用することにより、どのオブジェクトからマクロを呼び出したかが識別できるようになることです。
Public Sub objColor()

  Dim oj As String

  oj = ActiveSheet.DrawingObjects(Application.Caller).Name
  FormatColorRedBlue oj

End Sub

Public Sub FormatColorRedBlue(oj As String)

  Dim c As Integer

  c = ActiveSheet.DrawingObjects(oj).Interior.ColorIndex
  If c = 3 Then
    c = 4
  Else
    c = 3
  End If
  ActiveSheet.DrawingObjects(oj).Interior.ColorIndex = c

End Sub


●論理値を反転させたいとき

変数のデータ型に論理値を扱うboolean型がありますが、これを使うと真(True)と偽(False)の2値を使った判定が可能になることはご存知ですね。
この型で宣言した変数をフラグとして利用する場合に、フラグの中身を反転させる必要が生じたとき、みなさんはどうしますか?
Ifを使ってフラグの中身をセットする方法は誰でも思いつくとおもいますが、もっと簡単に反転させる方法があります。
一つはNotを使った式を使う方法、もう一つは条件式の結果を利用する方法です。

test1ではNotを使うことによりビットが反転しますので、真偽も反対になります。
test2ではa=1を括弧でくくることにより条件式となりますので、a=1を評価して、一致していれば真(True)が変数flgに格納され、不一致の場合は偽(False)が格納されます。
Public Sub test1()
  'Notを使った式

  Dim flg As Boolean

  flg = True
  flg = Not flg
  MsgBox "フラグは" & flg & "です。"

End Sub

Public Sub test2()
  '条件式の結果を利用

  Dim flg As Boolean
  Dim a As Integer

  a = 1
  flg = (a = 1)
  MsgBox "フラグは" & flg & "です。"

  flg = (a <> 1)
  MsgBox "フラグは" & flg & "です。"

End Sub


●クリックした行に色を付けたいとき

データ件数が多いとき、どの行を眼で追っていたかわからなくなるのを助けます。
シート上でクリックすると、その行だけ色がつきます。
単純ですが結構便利ですよ。
ワークシートのSelectionChangeイベントに記述してください。
色はRGB関数で指定します。それぞれ0(暗)〜255(明)までを、R(赤)G(緑)B(青)の要素別に指定してください。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  Dim r As Long

  '2行目以降でA列が空欄でないものが対象
  r = Target.Row
  If r > 1 And Range("A" & r).Value <> "" Then
    'セル全体の色を初期化
    Cells.Interior.ColorIndex = xlNone
    'クリックした行に色(ペールブルー)を付ける
    Range(r & ":" & r).Interior.Color = RGB(100, 200, 255)
  End If

End Sub


●ワークシート上のすべてのオブジェクト名を調べたいとき

ワークシート上に配置したオートシェイプやコマンドボタンの名前を知りたいとき、Shapesコレクションを使って調べることができます。
Shapesコレクションというのは、配置したオートシェイプやコマンドボタンの総称です。
例では、このコレクションをFor Each ステートメントで一つづつ名前を調べて、イミディエイトウィンドウに書き出しています。
イミディエイトウィンドウは、デバッグの際によく使うウィンドウで、「Ctrl + G」でコードウィンドウの下に表示されます。
Public Sub CheckObj()

  Dim ob As Shape

  For Each ob In Worksheets(1).Shapes
    Debug.Print ob.Name
  Next ob

End Sub


●ユーザーフォームの「×」ボタンを無効にしたいとき

ユーザーフォームの終了ボタンに特別の処理を持たせているとき、オペレータにフォームを「×」ボタンでいきなり閉じられないようにするためのコードです。
フォームを閉じる際には、必ずQueryCloseイベントが発生するので、そのときに閉じる理由が何であるかを判定してあげれば、動作を区別することが可能になります。
コードから閉じる場合は、引数にCloseMode=1(定数はvbFormCode)が渡りますが、「×」ボタンから閉じる場合はCloseMode=0になります。
値が1でなければ、メッセージを表示し、引数にCancel = 1をセットして、閉じる動作そのものをキャンセルします。
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

  If CloseMode <> vbFormCode Then
    MsgBox "[×]ボタンでは閉じれません。" & vbCrLf _
    & "「終了」ボタンで閉じてください。"
    Cancel = 1
  End If

End Sub


●計算式の中で文字列を引用符で囲みたいとき

計算式の中で文字列を引用符で囲むときは、引用符を重ねて囲みます。
例では、セルに書き込むときは=If(A1>0,"○","×")で表現されます。
Public Sub test()

  Cells(2, 1).Formula = "=If(A1>0,""○"",""×"")"

End Sub


●グラフサイズを統一したいとき

グラフのサイズは、グラフエリアの周りに表示されるサイズ変更ハンドルをドラッグすることで自由に変更できますが、複数のグラフを同じ大きさに揃えることは案外難しいものです。
このコードを実行すると、グラフの幅と高さを聞いてきますので、その値をcmで入力します。
どちらかの値が0の場合、または「キャンセル」ボタンが押されたときは、処理を中止します。
この処理はアクティブなシートに配置されているグラフに対してだけ実行されます。
【注意】
「キャンセル」ボタンが押されたときは、InputBox関数から数値が返ってきませんので、そのままだとエラーになってしまいます。
そこでVal関数を使ってすべて数値に変換した上で判定しています。
Public Sub SameSize()

  Dim myCht As ChartObject
  Dim gWidth As Integer
  Dim gHeight As Integer
  Dim myMsg As String
  Dim myTitle As String

  myTitle = "グラフサイズ指定"
  myMsg = "グラフの幅を入力してください。"
  gWidth = Val(InputBox(myMsg, myTitle, 0))

  myMsg = "グラフの高さを入力してください。"
  gHeight = Val(InputBox(myMsg, myTitle, 0))

  myTitle = "キャンセル処理"
  myMsg = "実行を中止します。"
  If gWidth = 0 Or gHeight = 0 Then
    MsgBox myMsg, vbExclamation, myTitle
    Exit Sub
  End If

  'グラフサイズを設定
  For Each myCht In ActiveSheet.ChartObjects
    myCht.Width = gWidth
    myCht.Height = gHeight
  Next

End Sub


●1つのシートだけのブックを新たに作成したいとき

現ブックに複数のシートがある場合、どれか一つだけを新規ブックにコピーし、名前を付けて保存するマクロです。 新ブックには一つだけシートが作成されています。
手動で行う場合は、シートタブを右クリックして、「移動またはコピー」→「移動先ブック名」を(新しいブック)に変更→「コピーを作成する」にチェックをつけるという操作になります。
Public Sub SingleSheetCopy()

  Dim SheetName As String
  Dim NewBook As String

  SheetName = "Sheet1" 'コピー元シート名
  NewBook = "CopyTest.xls" 'コピー先ブック名

  Worksheets(SheetName).Copy
  ActiveWorkbook.SaveAs Filename:=NewBook
  ActiveWorkbook.Close

End Sub

【応用】ワークシート1Pageだけを任意の場所に保存するコード
Public Sub CallSave()
  Dim myBook As Variant
  'データの有無をチェック
  If ActiveSheet.Cells(1, 1).Value = "" Then
  MsgBox "データが出力されていないため、保存できません。", _
  vbExclamation, "データの保存"
  Exit Sub
  End If
  '「名前を付けて保存」ダイアログ表示
  myBook = Application.GetSaveAsFilename("jusho.xls", _
  "Excelファイル,*.xls", , "ワークシートを保存")
  'キャンセル時の処理
  If StrConv(myBook, vbUpperCase) = "FALSE" Then Exit Sub
  'ワークシートを別名ファイルで保存
  ActiveSheet.Copy
  ActiveWorkbook.SaveAs Filename:=myBook
  ActiveWorkbook.Close
End Sub

●範囲名を自動で付けたいとき

データの増減に合わせて、範囲名を自動で設定するマクロです。
例ではSheet1のB列2行目からデータが入力されており、そのデータ件数が増減する場合を想定しています。
Public Sub RangeReName()

  Dim r1 As Integer
  Dim r2 As Integer
  Dim RngName As String

  '設定する範囲名
  RngName = "範囲B"
  'データの先頭の行
  r1 = 2
  'データの最後の行
  r2 = Range("B" & r1).End(xlDown).Row

  ActiveWorkbook.Names.Add Name:=RngName, _
    RefersToR1C1:="=Sheet1!R" & r1 & "C2:R" & r2 & "C2"

End Sub


●Changeイベントで特定セルを判定したいとき

これはワークシートのWorksheet_Changeイベントへ記述してください。
Worksheet_Changeイベントでは、すべてのセルで更新があった場合にイベントが発生してしまいますが、実際には特定セルでの更新のみを対象とすることがほとんどだと思います。
そこでIntersectメソッドを利用することで、簡単に特定セルを判定することができるようになります。
Intersectメソッドで、いくつかの引数(範囲)を列挙することで、その共有範囲を返します。
Target引数には更新中のセル情報(Rangeオブジェクト)が入るので、これと2番目に指定した範囲との共有部分があるかを判定し、あった場合の処理を記述します。
例ではA1からA10の範囲でセルの更新があった場合のみ、メッセージボックスを表示させます。
実際はここに何か具体的な処理を入れてください。

最後に、ひとつ注意しなければいけないことがあります。
引数Targetにセル1つの範囲しか入っていない場合は問題ないのですが、セルを複数選択した状態で変更するなどして、いくつかのセル範囲が入ってきた場合は、そのうちの1つでもIntersectメソッドで指定した範囲と重なれば有効とみなされます。
したがって想定外の結果がおこる場合もありますので、注意が必要です。
Private Sub Worksheet_Change(ByVal Target As Range)

  Dim isect As Range

  Application.EnableEvents = False
  Set isect = Application.Intersect(Target, Range("A1:A10"))
  If Not isect Is Nothing Then
    MsgBox "処理対象セルです。"
  End If
  Application.EnableEvents = True

End Sub


●自動リンクの更新メッセージを表示させないようにしたいとき

OpenメソッドのUpdateLinks引数に0を指定することでメッセージが表示されなくなります。
また、必ず更新するようにするには3を指定します。

【ヘルプ】
UpdateLinks
ファイル内のリンクの更新方法を指定します。
リンクが設定されているファイルを開くとき、この引数を省略すると、リンク更新のダイアログ ボックスが表示されます。

次のいずれかの値を指定します。

値 内容
0 外部参照、リモート参照ともに更新されません。
1 外部参照は更新され、リモート参照は更新されません。
2 リモート参照は更新され、外部参照は更新されません。
3 外部参照、リモート参照ともに更新されます。

外部参照とは他のブックを参照している場合を指します。
リモート参照とは別のアプリケーションへリンクされている場合を言うようです。
Public Sub Sample()

  'リンクを更新しないで開く
  Workbooks.Open FileName:="C:\Book1.xls", UpdateLinks:=0

  'リンクを更新して開く
  Workbooks.Open FileName:="C:\Book1.xls", UpdateLinks:=3

End Sub


●特定のセルのみ選択できるようにしたいとき

入力する人が次にどこに入力すればよいかが分かるように、特定のセルのみ選択できるようにしてあげることができます。
このコードを実行すると、セルに入力後EnterキーまたはTabキーを押すことで、次の入力すべきセルへセルポインタがジャンプします。
他のセルは選択できないようになっているので、入力者も迷うことはありません。
手順としては、あらかじめ入力すべきセルのロックをはずしておきます。(書式→セル→保護→ロックのチェックをはずす)
次にコードでシート保護をかけた後、EnableSelectionプロパティでxlUnlockedCellsを指定することで、ロックをはずしたセルのみしか選択できないようになります。
Sub Sheet_Protect()

  ActiveSheet.Protect
  ActiveSheet.EnableSelection = xlUnlockedCells

End Sub


ただしこの「保護されたセルを選択不可にする」マクロは、実行した直後は有効ですが、次回このマクロを実行したブックを開いても、セル選択ができてしまいます。
常にこの状態を作り出すためには毎回このマクロを実行する必要がありますので、その場合はThisWorkbookのWorkbook_Open()イベントに記述してください。

●シート上のコマンドボタンから他シートを操作したいとき

あるシートにコマンドボタンを作成して、他のシート上のセルを選択しようとしたとき、エラーになることがあります。([コントロールツールボックス]から作成した場合)
例えばSheet1上のコマンドボタンからSheet2のセルA1を選択しようとした場合、下記のコードを書いてしまうと、実行時エラー'1004'  「RangeクラスのSelectメソッドが失敗しました。」のメッセージが出て処理が中断してしまいます。
Private Sub CommandButton1_Click()

  Sheets("Sheet2").Select
  Range("A1").Select

End Sub

この場合は、いったん「操作したいワークシートをアクティブにして、そのシート上のセルA1を選択」とすることで回避できます。
Private Sub CommandButton1_Click()

  Sheets("Sheet2").Activate
  ActiveSheet.Range("A1").Select

End Sub

または標準モジュールに先ほどエラーになったコードを記述して、コマンドボタンでそのプロシージャを呼び出す形にすると今度は正常に動作します。
Public Sub test()

  Sheets("Sheet2").Select
  Range("A1").Select

End Sub

Private Sub CommandButton1_Click()

  test

End Sub
結論としてはシート上のコマンドボタンから、直接他シートのセルをselectすることはできないようです。

●Excelのバージョンを調べたいとき

標準モジュールに次のコードを書いて実行してください。
最初の例では現在開いているExcelのバージョンが表示されます。
バージョンにより記述できるコードが異なるような場合に利用できます。
これを応用して2番目の例ではバージョンによってシート保護のコードを分岐させて実行しています。
1つ注意しておかなければいけないのは、分岐内のコードは必ず実行時バインド型のコードにしておくことです。 実行前バインド型のコードだと、実行前にコンパイルエラーで止まってしまいます。
Public Sub DispVersion()
'Excelのバージョンを表示

    Dim V As String
    V = Application.Version
    
    Select Case V
      Case "7.0"
          MsgBox "Excel95 : " & "Version = " & V
      Case "8.0"
          MsgBox "Excel97 : " & "Version = " & V
      Case "8.0d"
          MsgBox "Excel97 SR-1 : " & "Version = " & V
      Case "9.0"
          MsgBox "Excel2000 : " & "Version = " & V
      Case "10.0"
          MsgBox "Excel2002 : " & "Version = " & V
      Case "11.0"
          MsgBox "Excel2003 : " & "Version = " & V
      Case "12.0"
          MsgBox "Excel2007 : " & "Version = " & V
    End Select
    
End Sub

例:バージョン分岐によるシート保護処理
If Val(Excel.Application.Version) >= 10 Then
        'Ecel2002以上
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
            Scenarios:=True, UserInterfaceOnly:=True, _
            AllowFormattingColumns:=True
Else
        'Excel2000以下
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
            Scenarios:=True, UserInterfaceOnly:=True
End If
		


●ブックのショートカットを作成したいとき

現在開いているブックのショートカットを、WSHの機能を利用してデスクトップ上に作成します。
通常は手動で行うことがほとんどでしょうが、自分以外の人にブックを使ってもらうときのセットアップ用に便利かもしれません。
Public Sub MakeSC1()

  Dim WSH As Object
  Dim DeskP As String
  Dim ShortC As Object

  'WSHオブジェクトを作成
  Set WSH = CreateObject("WScript.Shell")
  'デスクトップのパスを取得
  DeskP = WSH.SpecialFolders("Desktop")
  'ショートカットオブジェクトを作成
  Set ShortC = WSH.CreateShortcut(DeskP & "\" & ActiveWorkbook.Name & ".lnk")
  'ショートカットのリンクを設定
  ShortC.targetPath = ActiveWorkbook.FullName
  'ショートカットをデスクトップに作成
  ShortC.Save

  'オブジェクトを解放
  Set ShortC = Nothing
  Set WSH = Nothing

End Sub


任意のブックに対して作成することもできます。
「ファイルを開く」ダイアログを使って、目的のブックを指定するだけです。 後の処理はほとんど同じです。
注意したいのは「ファイルを開く」ダイアログで「キャンセル」ボタンが押されたときの判定です。
ここでは「キャンセル」ボタンが押されると、“False”が文字列で返ってくるのを利用して以降の処理を中止しています。
利用価値はあまりないかも知れませんが、一応掲載しておきます。
Public Sub MakeSC2()

  Dim TargetF As String
  Dim TargetP As String
  Dim WSH As Object
  Dim DeskP As String
  Dim ShortC As Object

  '「ファイルを開く」ダイアログ表示
  TargetF = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
  'ショートカットを作成するファイル名を取得
  If TargetF <> "False" Then
    TargetP = Right(TargetF, Len(TargetF) - _
      InStrRev(TargetF, "\", , vbTextCompare))
  Else
    MsgBox "キャンセルされました。"
    Exit Sub
  End If

  'WSHオブジェクトを作成
  Set WSH = CreateObject("WScript.Shell")
  'デスクトップのパスを取得
  DeskP = WSH.SpecialFolders("Desktop")
  'ショートカットオブジェクトを作成
  Set ShortC = WSH.CreateShortcut(DeskP & "\" & TargetP & ".lnk")
  'ショートカットのリンクを設定
  ShortC.targetPath = TargetF
  'ショートカットをデスクトップに作成
  ShortC.Save

  'オブジェクトを解放
  Set ShortC = Nothing
  Set WSH = Nothing

End Sub


●新規ブックに名前を付けて保存したいとき

保存先にフォルダを作成して、そこに新規ブックを保存するマクロです。
すでに同名のフォルダが存在する場合は、作成処理をスキップしてそのままそこに保存します。
このプロシージャを実行すると、まず新規のブックが1つ作成されます。
次に新規ブックのSheet1のA1セルに適当な値を書き込む処理を1行書いています。
書き込みが終わったら、新規ブックに名前を付けて、先ほど作成したフォルダに保存をします。
このとき既に同名のブックがあったとしても、そのまま上書きで保存されるように警告メッセージを出さないようにしています。
反対に上書き保存の確認メッセージが必要なときは、“Application.DisplayAlerts = False”を外して下さい。
Public Sub SaveNewBook()

  Dim MyDir As String
  Dim MyBook As String
  Dim MyNew As Workbook

  '保存先のディレクトリを作成(既に存在する場合はスキップ)
  On Error Resume Next
  MkDir ThisWorkbook.Path & "\_test"
  On Error GoTo 0
  '新規ブック名とパスを設定
  MyDir = ThisWorkbook.Path & "\_test"
  MyBook = "NewBook.xls"
  '新規ブックを作成
  Set MyNew = Workbooks.Add
  '新規ブックに値を格納
  ActiveWorkbook.Sheets(1).Range("A1").Value = "This is a NewBook."
  '新規ブックに名前を付けて保存
  Application.DisplayAlerts = False
  MyNew.SaveAs Filename:=MyDir & "\" & MyBook
  Application.DisplayAlerts = True
  'Excelを終了する
  Application.Quit

End Sub


●マクロモジュールを他のブックへコピーしたいとき

別なブックに特定の標準モジュールをコピーしたいときのコード例です。
使い道は色々考えられると思いますが、ここでは動作の説明だけしておきます。
この処理ではあらかじめモジュールのコピー先ブックが決まっており、そのブックに現在のブックの標準モジュールをコピーしようというものです。
新規のブックにコピーする場合は、自分で一部手直ししてください。

まずコピー先ブックを開きます。
コピー先ブックが見つからない場合は、処理を中止するようにしています。
ブックが存在しないときは新規にブックを作成するように変更してもよいでしょう。
次にこのマクロが書かれたブックのモジュール(標準モジュール2)を“TestM.bas”というファイル名でエクスポートします。ファイル名はそのまま“Module2”としてもかまいません。
引き続き今度はコピー先のブックに同モジュールをインポートします。
最後はコピー先ブックのみが画面上に表示されるので、モジュールの存在を確認してください。
標準モジュール1のプロシージャ
Public Sub CopyModule()

  Dim MyDir As String
  Dim CBook As Workbook
  Dim MyComp As Object
  Dim ModuleFile As String

  'コピー先ブックのパス
  MyDir = ThisWorkbook.Path & "\Test.xls"
  'コピー先ブックを開く
  On Error GoTo ERR_SHORI
  Set CBook = Workbooks.Open(MyDir)
  On Error GoTo 0
  'このブックのModule2をエクスポート
  ModuleFile = ThisWorkbook.Path & "\TestM.bas"
  Set MyComp = ThisWorkbook.VBProject.VBComponents("Module2")
  MyComp.Export ModuleFile
  'コピー先ブックにインポート
  CBook.VBProject.VBComponents.Import ModuleFile
  'このブックを閉じる
  ThisWorkbook.Close

ERR_SHORI:

  MsgBox Err.Description & _
    vbCrLf & "処理を中止します。"
  'Excelを終了する
  Application.Quit

End Sub

標準モジュール2のプロシージャ
Public Sub test()
  MsgBox "This is a Module2."
End Sub


●標準モジュールを解放(削除)したいとき

別なブックから、特定の標準モジュールを解放(削除)します。
このサンプルでは、特定のブック(abc.xls)に含まれている標準モジュール(Module1)を削除する例を示しています。なお2つのブックは同じ場所にあるものとします。
削除対象とするモジュールがない場合は、メッセージを表示して処理を中止します。
先のモジュールのコピーと組み合わせることで、モジュールの入れ替えができるかもしれません。
Public Sub DeleteModule()

  '削除対象モジュールを含むブックを開く
  On Error GoTo ERR_SHORI
  Workbooks.Open ThisWorkbook.Path & "\abc.xls"
  On Error GoTo 0

  '標準モジュールを解放する
  On Error GoTo ERR_SHORI
  With Workbooks("abc.xls").VBProject
    .VBComponents.Remove .VBComponents("Module1")
  End With
  On Error GoTo 0

  '解放後のブックを上書き保存する
  ActiveWorkbook.Save
  'Excelを終了する
  Application.Quit
  Exit Sub

ERR_SHORI:

  If Err.Number = 9 Then
    MsgBox "削除対象モジュールが見つかりませんでした。" & _
     vbCrLf & "処理を中止します。"
  Else
    MsgBox Err.Description & _
     vbCrLf & "処理を中止します。"
  End If
  'Excelを終了する
  Application.Quit

End Sub


パスからファイル名のみを取り出したいとき

ファイルパスからファイル名のみを取り出して返す関数です。
引数にそのファイルまでのフルパスを与えると、ファイル名だけを取り出して返してくれますので、いろいろなケースで部品として使えると思います。

まずInStrRev関数を使って、引数のパスの後ろから\記号が含まれているかどうかを調べていきます。 \記号が見つからなければlngPos=0のままで、\記号が見つかるとその位置がlngPosに格納されます。
今度は同様にピリオド(.)が含まれているかどうかを調べ、そのピリオドの位置と先ほどの\記号の位置とを比較します。
\記号の位置よりもピリオドの位置が後にあれば、それはファイル名と拡張子を分けているピリオドであると判断できるので、その場合はblnInclude=Trueとなります。
引数のパスに\記号が含まれており(lngPos > 0)、なおかつ\記号より以降にピリオドが見つかった場合(blnInclude=True)は、\記号以降の部分がファイル名と考えられるので、その部分を取り出し、関数の戻り値としてセットしてあげます。

ちなみにパスからファイル名を除いた部分を取り出す場合はAのようにします。
Function NameFromPath(strPath As String) As String

    Dim lngPos As Long
    Dim strPart As String
    Dim blnInclude As Boolean

    'ファイルパスかどうかを調る
    lngPos = InStrRev(strPath, "\")
    blnInclude = InStrRev(strPath, ".") > lngPos

    '@パスからファイル名部分を取り出す
    If lngPos > 0 Then
        If blnInclude Then
            strPart = Right$(strPath, Len(strPath) - lngPos)
        End If
    End If
    
    NameFromPath = strPart
    
End Function


Public Function FolderFromPath(strPath As String) As String

    Dim lngPos As Long
    Dim strPart As String
    Dim blnInclude As Boolean

    'ファイルパスかどうかを調る
    lngPos = InStrRev(strPath, "\")
    blnInclude = InStrRev(strPath, ".") > lngPos

    'Aパスからファイル名を除いた部分を取り出す
    If lngPos > 0 Then
        If blnInclude Then
            strPart = Left$(strPath, lngPos)
        End If
    End If
    
    FolderFromPath = strPart
    
End Function

		


現在開いているブックの一覧を取得したいとき

複数のブックを用いてマクロで処理をする場合に、よく見かける書き方です。
ここではブックのCountプロパティを調べてその数だけループして調べるやり方と、Workbooksコレクションの各要素(Workbookオブジェクト)に対して順番に調べていく方法を紹介しておきます。
■For Next を使った例
Sub OpenList_1()

    Dim i As Long
    Dim tmp As String

    For i = 1 To Workbooks.Count
        tmp = tmp & Workbooks(i).Name & vbCrLf
    Next i
    MsgBox "現在開いているブックは、" & vbCrLf & tmp & "です。"

End Sub


■For Each Next を使った例
Sub OpenList_2()

    Dim wb As Workbook
    Dim tmp As String

    For Each wb In Workbooks
        tmp = tmp & wb.Name & vbCrLf
    Next wb
    MsgBox "現在開いているブックは、" & vbCrLf & tmp & "です。"

End Sub
		


メニューバーの一部を無効にしたいとき

メニューバーの一部の項目を無効にして、ユーザーに直接操作されないようにすることができます。
こうすることで、ユーザーに必ずマクロを使って操作してもらうことができ安全です。
ただし、ツールバーは普通に使用できるので、こちらも別に対策をしておかなければ意味がないかもしれません。
下の例ではメニューバーから「ファイル」→「上書き保存」と「ファイル」→「名前を付けて保存」が選択できないようにしています。
メニューの項目は直接Controls("上書き保存(&S)")というように指定してもよいし、インデックス番号でControls(4)のようにしてもかまいません。
注意すべきことはExcelを終了する前に、必ずメニューバーを元の状態に戻しておかなければ、永久にそのままの状態になってしまいます。
Private Sub Workbook_Open()
'***************************************************
'   「ファイル」→「上書き保存」を無効にする
'   「ファイル」→「名前を付けて保存」を無効にする
'***************************************************

    Dim MyMenuBar As CommandBar
    
    Set MyMenuBar = Application.CommandBars("Worksheet Menu Bar")
    MyMenuBar.Controls(1).Controls(4).Enabled = False '上書き…
    MyMenuBar.Controls(1).Controls(5).Enabled = False '名前を…
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'***************************************************
'   「ファイル」→「上書き保存」を有効に戻す
'   「ファイル」→「名前を付けて保存」を有効に戻す
'***************************************************

    Dim MyMenuBar As CommandBar
    
    Set MyMenuBar = Application.CommandBars("Worksheet Menu Bar")
    MyMenuBar.Controls(1).Controls(4).Enabled = True  '上書き…
    MyMenuBar.Controls(1).Controls(5).Enabled = True  '名前を…
    
End Sub
		


ユーザフォームに動的にコマンドボタンを追加したいとき

下記のコードをUserFormモジュールに記述してください。
まずユーザフォームに予めCommandButton1を配置しておきます。
次回マクロによりユーザフォームを表示したときにCommandButton1を押すたびに、新しいコマンドボタンが最大3つまで追加されていきます。
また、それぞれ追加されたボタンを押すと、クリックイベントが発生し、メッセージを表示するようにしています。
なお冒頭のWithEventsでの宣言は、コマンドボタンのイベントを利用するためのものです。
Option Explicit

Private WithEvents myB1 As MSForms.CommandButton
Private WithEvents myB2 As MSForms.CommandButton
Private WithEvents myB3 As MSForms.CommandButton

Private Sub CommandButton1_Click()

    Static cnt As Long
    Dim cmdObj As MSForms.CommandButton
    
    Set cmdObj = Controls.Add("Forms.CommandButton.1")
    
    cnt = cnt + 1
    
    Select Case cnt
        Case 1
            Set myB1 = cmdObj       'myB1ボタンを追加
            With myB1
                .Top = 10
                .Left = 10
                .Width = 50
                .Height = 24
                .Caption = "myB1"
            End With
        Case 2
            Set myB2 = cmdObj       'myB2ボタンを追加
            With myB2
                .Top = 10
                .Left = 92
                .Width = 50
                .Height = 24
                .Caption = "myB2"
            End With
        Case 3
            Set myB3 = cmdObj       'myB3ボタンを追加
            With myB3
                .Top = 10
                .Left = 174
                .Width = 50
                .Height = 24
                .Caption = "myB3"
            End With
            CommandButton1.Enabled = False
    End Select
    
End Sub

Private Sub myB1_Click()

    MsgBox "myB1" & vbTab & "Top=" & myB1.Top & " : " & "Left=" & myB1.Left _
        & " : " & "Height=" & myB1.Height & " : " & "Width=" & myB1.Width
    
End Sub

Private Sub myB2_Click()

    MsgBox "myB2" & vbTab & "Top=" & myB2.Top & " : " & "Left=" & myB2.Left _
        & " : " & "Height=" & myB2.Height & " : " & "Width=" & myB2.Width
    
End Sub

Private Sub myB3_Click()

    MsgBox "myB3" & vbTab & "Top=" & myB3.Top & " : " & "Left=" & myB3.Left _
        & " : " & "Height=" & myB3.Height & " : " & "Width=" & myB3.Width
    
End Sub
		


フォルダ参照ダイアログボックスを表示させたいとき

ファイルを開くのではなくて、フォルダを指定するためのダイアログボックスを使いたいということは、よくあります。
ここではWindowsでよくおなじみのフォルダ参照ダイアログボックスを呼び出すためのコードを掲載しておきます。
ただ、この処理はVBAの機能だけでは実現できないため、APIを利用してWindowsの機能を利用することになります。 そのためにコードが少々長く、また難解になりますが、ほとんどはそのままコピー&ペーストで動作すると思います。

まず下記のコードをすべて標準モジュールにそのまま貼り付けてください。
とくに冒頭の宣言部分は大事ですので、スペルミスがないようにしてください。
標準モジュールに記述したら、後は何らかの手段でプロシージャRefFolderを呼び出せば、フォルダ参照ダイアログボックスが開きます。
ここでは、一度指定したフォルダのパスをSheet1のセルA1に記憶させることで、2度目に開いたとき前回のフォルダを表示するようにしています。
ダイアログボックスで「キャンセル」を選択するか、セルA1を手動でクリアすれば、初期値の表示に戻ります。
Public Declare Function SendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, lParam As Any) As Long

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
    "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1

Public Const CSIDL_DESKTOP = &H0
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const MAX_PATH = 260

Public Type BROWSEINFO
      hwndOwner As Long
      pidlRoot As Long
      pszDisplayName As String
      lpszTitle As String
      ulFlags As Long
      lpfn As Long
      lParam As String
      iImage As Long
End Type


Public Function BrowseCallbackProc(ByVal hWnd As Long, _
    ByVal uMsg As Long, ByVal lParam As Long, _
    ByVal lpData As Long) As Long
'***************************************************
'   コールバック関数
'***************************************************

      If uMsg = BFFM_INITIALIZED Then
            SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData
      End If

End Function


Public Function FARPROC(pfn As Long) As Long
'***************************************************
'   AddressOf演算子の戻り値を戻す関数
'***************************************************

      FARPROC = pfn

End Function



Sub RefFolder()
'***************************************************
'   フォルダ参照ダイアログ呼び出し
'***************************************************

    Dim Browse As BROWSEINFO
    Dim pID&
    Dim PathName$
    Dim Fn%

    With Browse
          .pidlRoot = CSIDL_DESKTOP
          .lpszTitle = "目的のフォルダを選択してください"
          .ulFlags = BIF_RETURNONLYFSDIRS
          .lpfn = FARPROC(AddressOf BrowseCallbackProc)
          .lParam = Worksheets("Sheet1").Range("A1").Value _
            & vbNullChar   '初期フォルダのパス名
    End With

    '「フォルダの参照」ダイアログの呼び出し
    pID& = SHBrowseForFolder(Browse)

    If pID& Then
          '予めNull文字をセット
          PathName$ = String(MAX_PATH, vbNullChar)

          'フォルダのパス名を取得
          SHGetPathFromIDList pID&, PathName$

          '割り当てられたメモリを開放
          CoTaskMemFree pID&

          Fn% = InStr(PathName$, vbNullChar)
          If Fn% Then
              'ワークシートに現在のパスを書き込む
              Worksheets("Sheet1").Range("A1").Value _
                 = Left(PathName$, Fn% - 1)
          End If

    Else

          Worksheets("Sheet1").Range("A1").Value = ""

    End If

End Sub

		


マクロ名を表示させたくないとき

普通に標準モジュールにSubプロシージャを記述すると、Excelの「ツール」→「マクロ」→「マクロ」でマクロ実行ウィンドウにマクロ名が表示されます。
しかし場合によっては、ユーザーに勝手にマクロウィンドウからマクロを実行されては困るというケースもあるでしょう。 そういうときには、PblicになっているSubプロシージャをPrivateに変更すると、マクロ名が表示されなくなります。
ただし、例えPrivateに変更してマクロウィンドウに表示されなくなっても、直接マクロ名を"test2"のように入力して、実行ボタンを押すと実行されてしまいますので、あくまでも実行しにくくするという程度に考えてください。

さらに、Privateに変更した場合は、呼び出し方法に少し注意が必要となります。
例ではSheet1にPublicのSubプロシージャとPrivateのSubプロシージャを呼び出した場合の結果を示しています。 Publicの場合は問題なくプロシージャは実行されますが、Privateでは図のようにエラーとなってしまいます。 これはプロシージャにも変数同様に実行できる有効範囲(スコープ)というものが決められており、Privateの場合はその記述された同一モジュール内でしか実行できないためです。 ちなみにPublicの場合は、どのモジュールからでも実行することができます。

プロシージャのスコープ例
Publicプロシージャの呼び出し
Privateプロシージャの呼び出し

また、Publicのままでも引数があると、マクロ名が表示されませんので、これを利用してダミーの引数を持たせるのも有効です。
ただし、これも呼び出し時に今度は必ず引数をつける必要がでてきます。

Functionプロシージャも引数あるなしに関わらずマクロウィンドウには表示されません。
しかしながらこれもExcelのユーザー定義関数を呼び出すウィンドウからは、実行ができてしまいますので注意してください。

プロシージャのスコープ例

Option Explicit

'マクロウィンドウに表示される
Public Sub test1()
    MsgBox "test1"
End Sub

'Privateはマクロウィンドウに表示されない
Private Sub test2()
    MsgBox "test2"
End Sub

'Publicでもダミー引数を持たせると
'マクロウィンドウに表示されない
Public Sub test3(a As Integer)
    MsgBox "test3"
End Sub

'Functionプロシージャは
'マクロウィンドウに表示されない
Public Function test4(a As Integer)
    MsgBox "test4"
    test5 = "test4"
End Function

'引数がなくても表示されない
Public Function test5()
    MsgBox "test5"
    test5 = "test5"
End Function
		


ロックがかかっていないセルを調べたいとき

自分が作ったシートでない場合、どのセルにロックがかかっていて、どのセルにかかっていないか不明なときがありますね。
手作業で一つ一つセルの書式を調べていってもいいですが、面倒な場合はマクロでいっきに調べる手もあります。
例ではロックが解除されているセルを調べていますが、CL.Locked = Trueに変更すれば、当然ロックがかかっているセルを調べることもできます。
下記コードはSheet1の範囲A1:E20を調べて、その結果をSheet2に出力しています。
結果を残したくなければ、Debug.Printでイミディエイトウィンドウに書き出せばOKです。

ただワークシート上で確認するだけだったら、ロックがかかっているセルを調べるで紹介した条件付書式設定で調べたほうが簡単です。 これはあくまでもセルの保護ロック情報をコードで使用する場合ということで参考にしてください。
Public Sub UnLockedCell()

    Dim CL As Range
    Dim i As Long
    
    i = 1
    For Each CL In Sheet1.Range("A1:E20")
        If CL.Locked = False Then
            Sheet2.Cells(i, 1).Value = CL.Address
            i = i + 1
        End If
    Next

End Sub
		


リストボックスを複数列にして見出しを付けたいとき

すでにSheet1のA1:C1に見出しが設定されており、A2:C6にデータが入力されているものとします。
リストボックスのColumnHeadsプロパティをTrueにすることで見出し欄をリストボックス最上部に表示できます。
次にColumnCount、ColumnWidthsプロパティで列数と列幅を設定します。
データの参照範囲設定では必ずRowSourceプロパティを使用し、見出し行を除いた範囲をシート名を含めて指定します。
なおAddItemメソッドでリストボックスを作成した場合は、見出しの設定はできません。
Private Sub UserForm_Initialize()

    With ListBox1
        .ColumnHeads = True                         '見出しあり
        .ColumnCount = 3                            '列数
        .ColumnWidths = "2cm;4cm;3cm"               '列幅
        .RowSource = "Sheet1!A2:C6"                 '参照範囲
    End With

End Sub
		


マクロを一定時間停止させたいとき

Now()関数で現在時刻を取得し、それにmySecに代入した秒数だけ経過した時刻に達したとき、Application.Waitを実行します。
TimeSerial関数では、時・分・秒を指定できますが、サンプルは現在時刻にある秒数を加えた時刻が必要なので、あえて時・分は指定していません。
Public Sub PauseMac()

    Dim mySec As Long
    
    mySec = 5

    Application.Wait Now() + TimeSerial(0, 0, mySec)
    MsgBox mySec & "秒 経過しました。"
    
End Sub

		


メニューにチェックマークをつけたいとき

メニューの項目を実行したら、その項目にチェックマークを付けます。
サンプルではテスト1とテスト2をそれぞれ実行し、実行後に項目の先頭にチェックマークが付きます。
必ずファイルオープン時に、メニューバーに自作マクロを追加し、ファイルをクローズするときに元の状態に戻してください。
解除を忘れると、いつまでもメニューバーに残りっぱなしになってしまいます。
Option Explicit
Const BarName As String = "Worksheet Menu Bar"
Public Sub AddMenu()
'**********************************************************
'  メニューバーに追加する
'**********************************************************

    Dim myMenu As Variant
    Dim myMacro As Variant
    
    '新メニューを追加
    Set myMenu = Application.CommandBars(BarName). _
        Controls.Add(Type:=msoControlPopup)
    myMenu.Caption = "テスト(&T)"
    
    'マクロ(1)
    Set myMacro = myMenu.Controls.Add
    With myMacro
        .Caption = "テスト1(&X)"
        .OnAction = "test1"
    End With
    
    'マクロ(2)
    Set myMacro = myMenu.Controls.Add
    With myMacro
        .Caption = "テスト2(&Y)"
        .OnAction = "test2"
    End With
    
End Sub

Public Sub test1()
'**********************************************************
'   テスト1 マクロ
'**********************************************************

    MsgBox "テスト1を実行しました。"
    With Application.CommandBars(BarName). _
        Controls("テスト(&T)").Controls("テスト1(&X)")
        .State = Not .State
    End With
    
End Sub

Public Sub test2()
'**********************************************************
'   テスト2 マクロ
'**********************************************************

    MsgBox "テスト2を実行しました。"
    With Application.CommandBars(BarName). _
        Controls("テスト(&T)").Controls("テスト2(&Y)")
        .State = Not .State
    End With

End Sub

Public Sub ResetMenu()
'**********************************************************
'   メニューバーをリセットする(元の状態に戻す)
'**********************************************************
    
    Application.CommandBars(BarName).Reset

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'**********************************************************
'  メニューバーをリセットを呼び出す
'**********************************************************

    ResetMenu

End Sub

Private Sub Workbook_Open()
'**********************************************************
'  メニューバーに追加を呼び出す
'**********************************************************

    AddMenu

End Sub

		


Excelの「×」ボタンを無効にしたいとき

マクロ作成者の立場から、必ず所定の手続きが完了しないと、ユーザーにExcelを(またはブックを)終了してほしくないという場合はありませんか?
サンプルではExcelの(またはシートの)×ボタンを無効にして、マクロからのみ終了できるようにしてあります。 (メニューバーの「ファイル」→「終了」からも終了できません)
終了させる場合は、必ずowaruプロシージャを呼び出して終了させます。
内容は簡単で、終了操作で生じるBeforeCloseイベントを検知したときに、こちらで用意した変数p_CloseがFalseの場合は引数CancelにTrueを設定することで、終了できなくしてあげればいいのです。
マクロからの終了処理時にのみ、p_CloseにTrueを代入して、終了無効判定にかからないようにしてあげます。
■ThisWorkbookに記述
Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If Not p_Close Then
        MsgBox "終了できません"
        Cancel = True
    End If
    
End Sub

■標準モジュールに記述
Public p_Close As Boolean

Public Sub owaru()

    p_Close = True
    Application.Quit
    
End Sub

		


ブック内のハイパーリンクアドレスをすべて抽出したいとき

ブックの各シートにたくさんのハイパーリンクを設定している場合に、そのアドレスを抽出するマクロです。
サンプルではイミディエイトウィンドウに表示していますが、ワークシート、テキストファイル等に落とすことも同様な方法でできますので、各自でアレンジしてみてください。
Public Sub GetHyperLink()

    Dim i As Integer
    Dim ws As Worksheet
    
    For Each ws In Worksheets
        For i = 1 To ws.Hyperlinks.Count
            Debug.Print ws.Hyperlinks(i).Address
        Next i
    Next ws

End Sub

		


メッセージを表示させないでブックを閉じたいとき

ブックを変更しないで閉じる場合は問題ありませんが、ブックに変更を加えて閉じる場合、Excelでは必ず変更を保存するかどうかを確認するメッセージが表示されます。 手動で操作する場合このメッセージは必要ですが、マクロで自動処理をさせるときは、このメッセージのために連続した動作が途切れるため、メッセージを出さずに次の処理に移るようにしたいケースがよく発生します。

保存確認のメッセージを出さない方法としては、2つのやり方が考えられます。
一つは、ブックに変更があってもなくても必ず保存してから閉じるようにするか、変更があってもシステムに変更がないように見せかけ、更新せずにそのまま閉じる方法です。
二つ目は名前を付けて保存する場合などで“既に同名のファイルがあるが置き換えるか”というようなメッセージが表示されますが、強制的にこのメッセージ表示をOFFにして、必ずファイルを置き換えて終了する方法です。
後者の場合、一時的に「Application.DisplayAlerts = False」にすることでメッセージの出力を抑制することができます。
サンプルはそれぞれの場合のブックの閉じ方の一例を挙げています。
※強制的に更新して閉じる
Saveメソッド使用
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '強制的に更新して終了
    ThisWorkbook.Save
End Sub

Closeメソッド使用
Public Sub Owari()
    '強制的に更新して閉じる
    ThisWorkbook.Close SaveChanges:=True
End Sub

※更新しないで閉じる
SavedプロパティをTrueに設定
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '更新しないで終了
    ThisWorkbook.Saved = True
End Sub

Public Sub Owari()
    '更新しないで閉じる
    ThisWorkbook.Close SaveChanges:=False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'メッセージ表示を強制的にOFFにする場合
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs "C:\closetest.xls"
    Application.DisplayAlerts = True
End Sub

Public Sub SaveHantei()
'クローズ時の自動判定
    With ThisWorkbook
        If .Saved = True Then
            '更新していなければそのまま閉じる
            .Close SaveChanges:=False
        Else
            '更新していれば保存して閉じる
            .Close SaveChanges:=True
        End If
    End With
End Sub
		


右クリック時にショ−トカットメニュ−を表示させたくないとき

Worksheet_BeforeRightClickイベント実行時にセルのショートカットを表示させない方法です。
要はCancel = Trueで、右クリックイベントの発生を無効にしてあげればいいだけです。
MsgBox "RightClick"の部分に、実際に処理させたいコードを記述してください。
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
	Cancel As Boolean)

    Cancel = True
    MsgBox "RightClick"

End Sub
		


 


office boole banner 長崎県長崎市 オフィス・ブール 末永
E-mail: QYN00313@nifty.com   Tel/Fax: 095-893-6090