オフィス・ブールは、Excel全般について皆さまのお仕事をサポートします。
オフィス・ブールのロゴ
 代 表   : 末永 尚登(スエナガ ヒサト)
 E-mail  : suenaga@officeboole.com
 携 帯  : 070-4087-0025
 TEL/FAX    : 095-893-6090



title

(さあ困った、どうしよう?というときどうぞ)
VBA2編 フォルダを指定してファイルを選択したいとき
データが入力されているセル幅を自動調節したいとき
テキストファイルを読み書きしたいとき
文字列を選択状態にしたいとき
シート行の最大値65536を使わずにデータの最後行を取得
フォームを表示した状態でワークシートをスクロールさせたいとき
ファイル名を変更(リネーム)したいとき
ユーザーフォームを任意の位置に表示したいとき
拡張子を特定してファイル一覧を取得したいとき
InputBox関数で押されたボタンを識別したいとき
InputBox関数で文字のみ入力を可能としたいとき
特定文字列を含むBook名からその正式Book名を取得したいとき
計算式が入ったセル以外をクリアしたいとき
タイトルの年度表示を変更したいとき
指定したアドレスから列名を取り出す
特殊フォルダのパスを取得したいとき
連続したセル範囲の値を配列に格納したいとき
VBAにファンクションキーを認識させたいとき
多次元配列で各配列要素の上限を求めたいとき
必ず指定したセルが画面の左上隅に表示されるようにしたいとき
ユーザーフォームを画面いっぱいいに表示したいとき
名前を付けて保存ダイアログを表示したいとき
選択(クリック)した行に色を付けたいとき
フォルダ参照ダイアログでパスを取得したいとき
1月1日から数えて指定日が第何週目かを知りたいとき
ユーザーフォームにハイパーリンクを設定したいとき
生年月日から年齢を計算したいとき
OnActionプロパティを使って、実行マクロに引数を渡したいとき
セルサイズに画像のサイズを合わせたいとき
配列を初期化したいとき
ファイルのコピーと削除をVBAで実行したいとき
開いているすべてのフォーム名を取得したいとき
ワークシートにイベント処理を記述したくないとき
空白を含む文字列からすべての空白を取り除きたいとき
一定間隔でマクロを実行させたいとき
ワークシート関数と同等のRound 関数を使用したいとき
値貼り付けを簡潔にコーディングしたいとき
オブジェクトのセル番地を取得したいとき
シートに保護がかかっているかどうか調べたいとき
スクロールエリアを制限したいとき
押されたボタンの名前を取得したいとき
複数オブジェクトを選択したいとき
ワークシートのオブジェクト名(コード名)を調べたいとき
入力後のセル移動を変更したいとき
フォルダ内のファイル名をリスト表示
レベル制御(小計の出力)を行いたいとき
一時的にプリンタを変更したいとき
ファンクションキーにマクロを割り当てたいとき
固定長レコードを読み込みたいとき
選択したオブジェクトのみを処理したいとき
自作のメンバーリストから定数を入力したいとき
セル値を文字列と数字に分離したいとき

Excel編へ

●フォルダを指定してファイルを選択したいとき

通常「ファイルを開くダイアログ」を表示した場合、「ツール」→「オプション」のExcelのカレントフォルダ欄に設定されたフォルダが最初に開きます。
これを任意のフォルダを指定して開くようにするには、Application.GetOpenFilenameを実行する前にWScriptのCurrentDirectoryプロパティのカレントフォルダを変更する必要があります。
CurDirで現在のパスが取り出せますので、実行前パスを保存しておき、ファイルを選択した後は元のカレントフォルダに戻してあげたほうがよいでしょう。
Public Sub SelectedFolOpen()
'フォルダを指定して「ファイルを開く」ダイアログを呼び出す

    Dim myCurDir As String
    Dim myFile As String
    Dim myTitle As String

    myTitle="ファイルの選択"    
    '実行前のカレントフォルダ記憶
    myCurDir = CurDir
    'カレントフォルダ変更                                          
    CreateObject("WScript.Shell").CurrentDirectory = "D:\"                   
    myFile = Application.GetOpenFilename("Excelファイル,*.xls", , myTitle)
    'カレントフォルダを元に戻す
    CreateObject("WScript.Shell").CurrentDirectory = myCurDir
    If myFile = "False" Then
        MsgBox "キャンセルされました。"
    End If

End Sub

		


データが入力されているセル幅を自動調節したいとき

データが入力されている列に対して、そのセル幅を自動調節してくれます。
UsedRangeプロパティを使用することで、対象セル範囲を限定しています。
Public Sub AutoFitMac()
'セル幅を自動調節する

    ActiveSheet.UsedRange.EntireColumn.AutoFit

End Sub
		


テキストファイルを読み書きしたいとき

テキストファイルの読み書きは、VBのOpenステートメントを使用する方法とファイルシステムオブジェクトを利用する方法があります。
Openステートメントは古くから使われており、分かりやすいですが定型的な処理しかできません。
ファイルシステムオブジェクトの方は様々なメソッドやプロパティが用意されているので、もっと細かな処理ができます。
ここでは両方のコーディング例を掲載しています。
用途に応じて使い方を考えてみてください。
Public Sub ReadText1()
'   Openステートメントを使用
'   行単位で読み込み

    Dim FileNumber As Long
    Dim FilePath As String
    Dim TextLine As String
    Dim ar As Variant
    Dim i As Long
    Dim gyo As Long
    
    FileNumber = FreeFile
    FilePath = ThisWorkbook.Path & "\test.txt"

    Open FilePath For Input As #FileNumber
    
    gyo = 1
    Do While Not EOF(FileNumber)
        Line Input #FileNumber, TextLine
        ar = Split(TextLine, ",")
        For i = 0 To UBound(ar)
            Cells(gyo, i + 1).Value = ar(i)
        Next i
        gyo = gyo + 1
    Loop
    
    Close #FileNumber
    
End Sub

Public Sub ReadText2()
'   Openステートメントを使用
'   項目単位で読み込み

    Dim FileNumber As Long
    Dim FilePath As String
    Dim ar(1 To 7) As String
    Dim i As Long
    Dim gyo As Long
    
    FileNumber = FreeFile
    FilePath = ThisWorkbook.Path & "\test.txt"

    Open FilePath For Input As #FileNumber
    
    gyo = 1
    Do While Not EOF(FileNumber)
        Input #FileNumber, ar(1), ar(2), ar(3), ar(4), ar(5), ar(6), ar(7)
        For i = 1 To UBound(ar)
            Cells(gyo, i).Value = ar(i)
        Next i
        gyo = gyo + 1
    Loop
    
    Close #FileNumber

End Sub



Public Sub ReadText3()
'   FileSystemObjectを利用
'   テキストファイルの読み込み(行単位、カンマ区切り)

    Dim FSO As Object
    Dim TSO As Object
    Dim TextLine As String
    Dim FilePath As String
    Dim ar As Variant
    Dim i As Long
    Dim gyo As Long
    
    FilePath = ThisWorkbook.Path & "\test.txt"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    gyo = 1
    Set TSO = FSO.GetFile(FilePath).OpenAsTextStream
    With TSO
        Do Until ..AtEndOfStream
            TextLine = .ReadLine
            ar = Split(TextLine, ",")
            For i = 0 To UBound(ar)
                Cells(gyo, i + 1).Value = ar(i)
            Next i
	    gyo = gyo + 1
        Loop
        .Close
        
    End With
    
End Sub

Public Sub ReadText4()
'   FileSystemObjectを利用
'   テキストファイルの読み込み(行単位、タブ区切り)

    Dim FSO As Object
    Dim TSO As Object
    Dim TextLine As String
    Dim FilePath As String
    Dim ar As Variant
    Dim i As Long
    Dim gyo As Long
    
    FilePath = ThisWorkbook.Path & "\test.txt"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    gyo = 1
    Set TSO = FSO.GetFile(FilePath).OpenAsTextStream
    With TSO
        Do Until .AtEndOfStream
            TextLine = .ReadLine
            ar = Split(TextLine, vbTab)
            For i = 0 To UBound(ar)
                Cells(gyo, i + 1).Value = ar(i)
            Next i
	    gyo = gyo + 1
        Loop
        
        .Close
        
    End With

End Sub

Public Sub WriteText1()
'   Openステートメントを使用
'   テキストファイルの書き込み(行単位、上書き)

    Dim FileNumber As Long
    Dim FilePath As String
    Dim TextLine As String
    Dim gyo As Long
    
    FileNumber = FreeFile
    FilePath = ThisWorkbook.Path & "\test.txt"

    Open FilePath For Output As #FileNumber
    
    gyo = 1
    Do While Cells(gyo, 1).Value <> ""
        TextLine = Cells(gyo, 1).Value
        Print #FileNumber, TextLine
        gyo = gyo + 1
    Loop
    
    Close #FileNumber

End Sub


Public Sub WriteText2()
'   Openステートメントを使用
'   テキストファイルの書き込み(行単位、追記)

    Dim FileNumber As Long
    Dim FilePath As String
    Dim TextLine As String
    Dim gyo As Long
    
    FileNumber = FreeFile
    FilePath = ThisWorkbook.Path & "\test.txt"

    Open FilePath For Append As #FileNumber
    
    gyo = 1
    Do While Cells(gyo, 1).Value <> ""
        TextLine = Cells(gyo, 1).Value
        Print #FileNumber, TextLine
        gyo = gyo + 1
    Loop
    
    Close #FileNumber

End Sub

Public Sub WriteText3()
'   Openステートメントを使用
'   テキストファイルの書き込み(項目単位、上書き)

    Dim FileNumber As Long
    Dim FilePath As String
    Dim gyo As Long
    
    FileNumber = FreeFile
    FilePath = ThisWorkbook.Path & "\test.txt"

    Open FilePath For Output As #FileNumber
    
    gyo = 1
    Do While Cells(gyo, 1).Value <> ""
        Write #FileNumber, Cells(gyo, 1).Value, Cells(gyo, 2).Value
        gyo = gyo + 1
    Loop
    
    Close #FileNumber

End Sub

Public Sub WriteText4()
'   FileSystemObjectを利用
'   テキストファイルの書き込み(行単位、カンマ区切り)

    Dim FSO As Object
    Dim OSB As Object
    Dim FilePath As String
    Dim gyo As Long
    
    FilePath = ThisWorkbook.Path & "\test.txt"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    '2→上書きモード※ True→ファイルが存在しなければ新規作成
    Set OSB = FSO.OpenTextFile(FilePath, 2, True)
    
    gyo = 1
    Do Until Cells(gyo, 1).Value = ""
        OSB.WriteLine Cells(gyo, 1).Value & "," & Cells(gyo, 2).Value
        gyo = gyo + 1
    Loop
    
    OSB.Close

End Sub
※追記モードで開く場合は8を、読込モードは1を指定してください。		
		


文字列を選択状態にしたいとき

テキストボックスに入力した値をチェックして、エラーの場合その文字列を選択状態(反転表示)にさせてオペレータに知らせたい場合に便利です。
このサンプルコードは、ユーザーフォームにTextBox1が配置してあり、そのボックスに入力された文字列をコマンドボタンで選択状態にする例です。
実際はエラーチェックルーティンと組み合わせて使われることが多いと思います。
SelStartプロパティは文字列をどの位置から選択するのかを指定し、SelLengthプロパティで選択範囲の長さを指定します。
この例ではLen関数でテキストボックスに入力されている文字列の長さを調べ、その値をSelLengthプロパティに設定しています。
Private Sub CommandButton1_Click()

    'テキストボックスに入力された
    '文字列を選択状態にする

    With TextBox1
        .SetFocus
        .SelStart = 0
        .SelLength = Len(.Value)
    End With
    
End Sub		
		


シート行の最大値65536を使わずにデータの最後行を取得

データの最後の行を求める場合、ワークシートの最大行番号65536行を指定して、そこから上に探索する方法が一般的です。
《例》EndRow = Sheet1.Range("A65536").End(xlUp).Row
しかし、これだとExcelの仕様が変わり、最大行が65536行でなくなった場合に問題が発生することが予想されます。
そこまで考えるなら次のコードのように変更すれば、大丈夫でしょう。
シートの最大値をコードで取得して、その値から上方に調べていくやり方です。
Dim RowsCount As Long
Dim EndRow As Long
    
With Worksheets("Sheet1")
    RowsCount = .Rows.Count
    EndRow = .Range("A" & RowsCount).End(xlUp).Row
End With
		


フォームを表示した状態でワークシートをスクロールさせたいとき

通常はフォームを表示する場合はUserForm1.Showと記述しますので、モーダルフォームとなり、フォーム以外での操作は受け付けられなくなります。
他の操作(ワークシートのスクロールなど)を行いたいときは、いったんフォームを閉じてから操作をしなければなりません。
しかしフォームをモードレス状態で開くと、フォームが表示されていても後ろにあるワークシートを触れるようになります。もちろんスクロールも自由自在です。
このようにモーダルフォームとは、そのフォームを閉じない限り他の操作ができないものを言い(アプリケーション内の他のフォームは無効になりますが、他のアプリケーションのフォームは有効です)、モードレスフォームとは、そのフォームを閉じなくても、別なオブジェクトを操作することができるものをいいます。
VBAではShowメソッドの引数にvbModelessを指定すれば、モードレスフォームとなります。
ただしOffice 97では、ユーザーフォームは常にモーダルでしか表示できません。
Public Sub callfrom()

    UserForm1.Show vbModeless
    
End Sub		
		


ファイル名を変更(リネーム)したいとき

ファイル名またはフォルダ名の名前を変更するにはNameステートメントを使います。
また、ファイル名を変更して、他のフォルダにファイルを移動させることもできます。
まず最初にMotoFileで名前を変更するファイル名を指定します。
次にNewFileで新しいファイル名を指定します。
どちらもフルパス(ドライブ名及びフォルダ名を含める)で記述してください。
ただしNewFileには、既に存在しているファイル名は指定できません。実際に運用する場合にはエラートラップが必要となります。
またNameステートメントは、ドライブ間ではファイルを移動しますが、MotoFileとNewFileで指定したドライブ名が同じ場合は、単に既存のフォルダの名前を変更します。
ファイルやフォルダを新しく作成することはできません。
現在、開いているファイルに対してNameステートメントを実行してもエラーにはなりませんが、内容を変更した場合は、閉じる際に「名前を付けて保存」になります。
さらにDOSコマンドのように (*) や (?) のワイルド カード文字が指定できないので、場合によっては自分で処理を付け加える必要があるでしょう。
Public Sub Rename()
    'ファイル名を付け替える(リネーム)

    Dim MotoFile As String
    Dim NewFile As String
    MotoFile = ThisWorkbook.Path & "\" & "old.txt"
    NewFile = ThisWorkbook.Path & "\" & "new.txt"
    Name MotoFile As NewFile

End Sub

		


ユーザーフォームを任意の位置に表示したいとき

ユーザーフォームを任意の位置に表示する場合は、まずユーザーフォームのStartUpPositionプロパティを0(手動)に設定します。
そのあとでTopとLeftプロパティに任意の座標を指定します。
設定は下の例のようにVBAで設定するか、または直接プロパティウィンドから設定してもかまいません。
Public Sub CallMenu()

    With UserForm1
        .StartUpPosition = 0
        .Top = 100
        .Left = 23
        .Show
    End With

End Sub

		


拡張子を特定してファイル一覧を取得したいとき

フォルダ内のファイル一覧を取得する方法についてはネット上にたくさん紹介されていますが、一番シンプルな方法を掲載しておきます。
サブフォルダも含めた一覧取得となると、かなり難しくなってきます(プロシージャの再帰呼出し等)ので他サイトで調べてください。
サンプルはマクロブックが置かれたフォルダにあるエクセルブックの一覧を取得できます。
Public Sub GetFileList()

    Dim myDir As String
    Dim i As Long
    
    '出力先ワークシートをクリア
    Cells.ClearContents
    
    '拡張子xlsのファイル一覧を取得する
    myDir = Dir(ThisWorkbook.Path & "\" & "*.xls", vbNormal)
    Do While myDir <> ""
        i = i + 1
        Cells(i, 1).Value = myDir
        myDir = Dir()
    Loop
    
End Sub

		


InputBox関数で押されたボタンを識別したいとき

InputBox関数で押されたボタンによる処理の分岐は、初心者にとって案外難しいものです。
ここではVBAの非表示メンバStrPtr関数を使って判定しています。
Public Sub InputCheck()

    Dim rs As String
    
    rs = InputBox("データを入力してください")
    
    If StrPtr(rs) = 0 Then
        MsgBox "「キャンセル」ボタンが押されました"
        Exit Sub
    Else
        MsgBox "「OK」ボタンが押されました"
    End If
    
End Sub
		
		


InputBox関数で文字のみ入力を可能としたいとき

入力された値が文字か数字かを判断するにはIsNumeric関数を使うと簡単です。 数字の場合はTrueが返されるので、Falseのときだけループを抜けるようにします。
キャンセルボタンが押されたとき、または何も入力しないでOKボタンを押したときは処理を中止します。
逆に数値のみの入力を判定するならば、InputBoxメソッドの方が便利かもしれません。
Public Sub GetOnlyChar()
    Dim rs As String
    Do
       rs = InputBox("文字のみ入力してください")
       If rs = "" Then Exit Sub
    Loop While IsNumeric(rs)
    MsgBox rs & "が入力されました。"
End Sub

Public Sub GetOnlyNum()	
    Dim RS As Long
    RS = Application.InputBox(prompt:="数値を入力してね", Type:=1)	
End Sub
		


特定文字列を含むBook名からその正式Book名を取得したいとき

あるフォルダ内の特定の文字列を含むブック名を検索して、その正式ブック名を取得する関数です。 CURRENTPATH定数にはあらかじめ現在の検索対象となっているパスが定義されているものとします。
関数GetFileNameFullに検索文字列を渡すと、該当するブックを探し出してその正式ブック名を文字列で返します。
ただし該当するブックが複数あっても、最初に見つかったブックの名前を返すだけですので、複数のブック名を取得させるためには各自で工夫してください。
Public Function GetFileNameFull(kw As String) As String

    Dim myDir As String
    Dim ps As Integer
    
    myDir = Dir(CURRENTPATH & "\" & "*.xls", vbNormal)
    Do While myDir <> ""
        ps = InStr(1, myDir, kw, vbTextCompare)
        If ps > 0 Then
            'ファイル名を取得
            GetFileNameFull = myDir
            Exit Function
        End If
        myDir = Dir()
    Loop
    
    'NG
    GetFileNameFull = ""
    
End Function

		


計算式が入ったセル以外をクリアしたいとき

値のみ(計算式が入ったセル以外)をクリアしたいときのサンプルです。
マクロを実行する前に、クリアしたい範囲を選択しておいてください。
マクロを実行すると、値のみが消去されます。
セルに計算式が埋め込まれているかどうかは、@ではHasFormulaプロパティで判断します。
AではSpecialCellsメソッドの最初の引数にxlCellTypeConstants(定数)を指定します。
Public Sub ClearValue1()
'@1つずつセルをクリア

    Dim C As Range
    
    For Each C In Selection
        If Not C.HasFormula Then
            C.ClearContents
        End If
    Next C
    
End Sub

Public Sub ClearValue2()
'ASpecialCellsメソッドで一括クリア

    Selection.SpecialCells(xlCellTypeConstants, _
        xlTextValues + xlNumbers).ClearContents
    
End Sub
		


タイトルの年度表示を変更したいとき

複数のワークシートにタイトルがあり、そのタイトルの一部に年度表示がされている場合、その年度をすべてのワークシートに対して変更していくのは結構面倒ですね。
このサンプルは、ワークシートのF1にタイトルの先頭が“平成18年度 各支店別売上実績…”などになっていて、その年度部分の数字のみを変更するときの例です。
ここでInputBox関数に入力する年度は、半角でも全角でもすべて全角に直されて書き込まれるようにしています。
Public Sub ChangeNendo()

    Dim rs As String
    Dim c() As String
    Dim i As Integer
    Dim j As Integer
    Dim strTitle As String
    Dim strNewTitle As String
    Dim Lrs As String
    
    rs = InputBox("新しい年度(数字)を入力してください")
    Lrs = StrConv(rs, vbWide)               '全角に変換
    
    If StrPtr(Lrs) = 0 Then
        'キャンセル
        
        Exit Sub
        
    Else
        '変更処理
        
        For j = 1 To ActiveWorkbook.Worksheets.Count
        
            Worksheets(j).Activate
            If InStr(1, ActiveSheet.Name, "月") Then
                strTitle = ActiveSheet.Range("F1").Value
                ReDim c(Len(strTitle)) As String
                'タイトルを1文字単位に分解する
                For i = 0 To Len(strTitle)
                    c(i) = Mid(strTitle, i + 1, 1)
                Next i
                
                '年度を置換
                c(2) = Mid(Lrs, 1, 1)
                c(3) = Mid(Lrs, 2, 1)
                
                'タイトルを書き戻す
                strNewTitle = ""
                For i = 0 To Len(strTitle)
                    strNewTitle = strNewTitle & c(i)
                Next i
                ActiveSheet.Range("F1").Value = strNewTitle
            End If
            
        Next j
        
    End If
    
    
End Sub
		


指定したアドレスから列名を取り出す

アクティブセルの列数がわかっていて、それを列名に変換したいときどうしますか?
列数と列名のテーブルを作っておき、参照するのもいいですが手間がかかりますね。
sampleのコードはネット上にあったものですが、知っていると非常に便利なコードだと思います。
Split関数を使うと文字列をelimiterで指定した記号で分割して、配列として返してくれます。
その配列から特定要素を指定すると、希望の値が取り出せます。
sampleではSelection.Addressで"$A$1"のような文字列が取得できますので、それを"$"で分割することにより、"","A","1"の3つの要素が返ってきます。
そのうちの要素1を指定することにより(配列の要素は0から始まります)、列名を取得できるようになっています。

これが使いづらいならば、自分でGetColName関数のようなものを作ってしまうのもいいでしょう。
GetColName関数に現在選択しているセルのアドレスを引数として渡すと、列名だけが返ってきます。
Sub sample()

    MsgBox Split(Selection.Address, "$")(1)

End Sub

Public Function GetColName(c As String) As String

    Dim ar
    ar = Split(c, "$")
    GetColName = ar(1)
    
End Function


Public Sub test()

    MsgBox GetColName(Selection.Address)
    
End Sub
		


特殊フォルダのパスを取得したいとき

特殊なフォルダはパソコンによって、あるいはWindowsによって場所がまちまちです。
そんなときそのパスを取得する方法を知っていれば便利ですね。
サンプル1では、デスクトップとマイドキュメントのパスを知ることができます。
サンプル2では、Windowsのセットアップ場所、システムフォルダ、一時フォルダのパスを取得できます。
Public Sub GetSpecialFolder_1()
'特殊フォルダのパスを取得_1
    Dim ws
    
    Set ws = CreateObject("WScript.Shell")

    MsgBox "Desktop= " & ws.SpecialFolders("Desktop")
    MsgBox "MyDocuments= " & ws.SpecialFolders("MyDocuments")
    
End Sub

Public Sub GetSpecialFolder_2()
'特殊フォルダのパスを取得_2

    Dim FSO
    Dim OBJ
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set OBJ = FSO.GetSpecialFolder(0)
    MsgBox "setup= " & OBJ.Path
    Set OBJ = FSO.GetSpecialFolder(1)
    MsgBox "system= " & OBJ.Path
    Set OBJ = FSO.GetSpecialFolder(2)
    MsgBox "temporary= " & OBJ.Path
    
End Sub
		


連続したセル範囲の値を配列に格納したいとき

連続した範囲のセルの値を配列に格納する場合は、配列をバリアント型(Variant)で変数を定義しておくのがミソです。
変数はデータ格納後は配列として操作できるようになります。
注意しておくことは、作成される配列は1次元配列ではなくて、配列名(1,1)から始まる2次元配列になるということです。
これはワークシートが行・列からなる2次元のシートなので想像できると思います。
格納データのサンプル
セルに格納された値
Public Sub SetToArray()

    Dim ar As Variant
    
    ar = Range("A1:E1").Value
    'B1の値を表示
    MsgBox ar(1, 2)
    
    'B2の値を表示
    ar = Range("A1:E2").Value
    MsgBox ar(2, 2)
    
End Sub		
		


VBAにファンクションキーを認識させたいとき

ユーザーフォームを表示してデータ入力などを行わせたいとき、キーボードから手を離してマウスで終了ボタンを押してもらうのは無駄な時間が発生してしまいます。
できればキーボードのみで終了操作をしてもらう方が効率がよいでしょう。
そういう場合にファンクションキーを使って終了処理ができないものでしょうか。
サンプルではフォームにテキストボックスが配置されており、そこにフォーカスが当たっている場合にF12キーを押されたことをVBAに認識させる例を示しています。
テキストボックスが複数置かれている場合は、そのすべてに同様の記述をすることで、どのタイミングでもファンクションキーを認識させることができます。
逆にいうとすべてのテキストボックスに記述しないと、意図した動作にならないかもしれません。
ExcelのVBAではユーザーフォームのKeyDownイベントに記述してもファンクションキーを認識してくれません。
「フォームは、コントロールが1つもないか、または表示されているすべてのコントロールが選択不可能に設定されている場合に限り、フォーカスを持つことができる」ためです。
Private Sub TextBox1_KeyDown(ByVal KeyCode As 
          MSForms.ReturnInteger, ByVal Shift As Integer)

    If KeyCode = vbKeyF12 Then
        MsgBox "F12が押されたよ。"
    End If
    
End Sub
		


多次元配列で各配列要素の上限を求めたいとき

1次元配列でしたら配列要素の上限はUBound(配列名)で求まることはご存知だと思います。
For〜Next文などで配列の要素を1つづつ取り出して処理する際にループカウンタの上限値として使用します。
ところで多次元配列の場合はどうするのでしょうか?
この場合、UBound(配列名)とすると1番目の配列要素の上限は取得できますが、2番目以降は取得できません。
ところがUBound(配列名, 要素番号)とすることで簡単に2番目以降の配列要素の上限も求まります。
Public Sub test()
'多次元配列で各配列要素の上限を求める

    Dim aa(1 To 5, 1 To 3)
    
    MsgBox UBound(aa)           '5を返す
    MsgBox UBound(aa, 1)        '5を返す
    MsgBox UBound(aa, 2)        '3を返す
    
End Sub		
		


必ず指定したセルが画面の左上隅に表示されるようにしたいとき

例えばSheet1を表示したら必ずセルK1が画面の左上にくるようにしたい、そういう場合のコードです。 オペレータに余分なスクロール動作をさせたくない場合などに利用できます。
Worksheets("Sheet1").Activate
Application.Goto Reference:=Range("$K$1"), Scroll:=True
		


ユーザーフォームを画面いっぱいいに表示したいとき

ユーザーフォームを表示する際にExcelのワークシートを見えないようにしたい場合に便利です。
ユーザーフォームのInitializeイベントに下記のコードを記入してください。
イベントの初期値はClickイベントになっていますので、必ずイベントの変更を行ってからコーディングしてください。
フォームを呼び出すと、画面いっぱいにフォームが表示されます。
「×」(クローズ)ボタンを無効にしていると、閉じるときに困りますので、実行の際には「閉じる」ボタンを設けておくとよいでしょう。

Application.Width : アプリケーション ウィンドウ(ここではExcelウィンドウ)の左端から右端までの距離を返します。
Application.Height : アプリケーション ウィンドウ(ここではExcelウィンドウ)の上端から下端までの距離を返します。
Private Sub UserForm_Initialize()

    Me.Width = Application.Width
    Me.Height = Application.Height
    
End Sub
		


名前を付けて保存ダイアログを表示したいとき

先頭の引数でデフォルトのファイル名を表示します。省略は可能です。
この引数を省略すると、作業中のブックの名前が使われます。
キーワードはInitialFilenameです。
2番目はファイルの候補を指定する文字列 (ファイル フィルタ文字列) を指定します。
キーワードはFileFilterです。
3番目は飛ばして4番目はダイアログ ボックスのタイトルを指定します。
キーワードはTitleです。 この引数を省略すると、"名前を付けて保存" になります。
Public Sub SaveBook()

    Dim myBook As Variant
    
    '「名前を付けて保存」ダイアログ
    myBook = Application.GetSaveAsFilename("test.xls", _
        "Excelファイル,*.xls", , "Excelブックを保存")
    'キャンセル時の処理
    If StrConv(myBook, vbUpperCase) = "FALSE" Then Exit Sub
    'ブックの保存
    ActiveWorkbook.SaveAs Filename:=myBook
    
End Sub
		


選択(クリック)した行に色を付けたいとき

任意のセルを選択(クリック)したときに、その行全体に色を付けるマクロです。
コードを記述する場所に注意してください。 ワークシートのSelectionChangeイベントを利用します。(標準モジュールではありません)
色を変更した後で、また他のセルをクリックした場合、前の変更した行の色を元に戻しています。
こうすることで、たくさんのデータの中で現在注視している行がはっきり分かり、データを見失うことを防げて便利です。
Private m_ROW As Long                   '変更前の行番号
Private m_IRO As Long                   '変更前の色
Private Const MYCOLOR As Long = 36      '変更する色番号

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'選択した行に色を付ける
    
    If Target.Row > 1 Then      '2行目以降を対象とする
        '変更前の色に戻す
        If m_ROW <> 0 Then
            Rows(m_ROW).Interior.ColorIndex = m_IRO
        End If
        '変更前の行番号と色を記憶
        m_ROW = Target.Row
        m_IRO = Rows(Target.Row).Interior.ColorIndex
        '色を変更
        Rows(Target.Row).Interior.ColorIndex = MYCOLOR
    End If
    
End Sub		
		


フォルダ参照ダイアログでパスを取得したいとき

フォルダ参照ダイアログを使って、選択したフォルダのパスを取得するコードです。
最も一般的に使われているかもしれません。
関数になっているので、使用するときは「変数=GetFolder()」のようにして使います。
Public Function GetFolder() As String
'ダイアログを開いて、選択フォルダのパスを返す

    Dim WSH
    Dim FolPath
    Dim strGuide As String
    
    strGuide = "フォルダを指定してください。"
    
    Set WSH = CreateObject("Shell.Application")
    Set FolPath = WSH.BrowseForFolder(0, strGuide, 0)
    
    If Not FolPath Is Nothing Then
        '[OK]
        GetFolder = FolPath.items.Item.Path
    Else
        '[Cancel]
        GetFolder = ""
    End If
    
End Function
		


1月1日から数えて指定日が第何週目かを知りたいとき

ワークシートのセル番地A1に調べたい日付が入っているものとします。
DatePart関数を利用すると、様々な時間間隔を調べることができます。
Excelサンプル

【構文】
DatePart(interval, date[,firstdayofweek[, firstweekofyear]])
 interval:必須。時間間隔の単位を指定。
 date:必須。日付を指定。
 firstdayofweek:週の始まりの曜日を表す定数を指定。デフォルト値はvbSunday(日曜日)。
 firstweekofyear:年度の第1週を表す定数を指定。デフォルト値はvbFirstJan1(1月1日を含む週を第1週)。

intervalの設定値
 yyyy:年
 q:四半期
 m:月
 y:年間通算日
 d:日
 w:週日
 ww:週
 h:時
 n:分
 s:秒
firstdayofweekの設定値
 vbUseSystem:0 NLS API の設定値を使います。
 vbSunday:1 (既定値) 日曜
 vbMonday:2 月曜
 vbTuesday:3 火曜
 vbWednesday:4 水曜
 vbThursday:5 木曜
 vbFriday:6 金曜
 vbSaturday:7 土曜
firstweekofyearの設定値
 vbUseSystem:0 NLS API の設定値を使います。
 vbFirstJan1:1 (既定値) 1月1日を含む週を年度の第1週とする。
 vbFirstFourDays:2 7日のうち少なくとも4日が新年度に含まれる週を年度の第1週として扱う。
 vbFirstFullWeek:3 全体が新年度に含まれる最初の週を年度の第1週として扱う。

Public Sub test()

    Dim myDate As Date
    
    myDate = Cells(1, 1).Value
    
    MsgBox "1月1日を含む週を第1週目として数えた場合、" & myDate & "は第" _
        & DatePart("ww", myDate) & "週目です。"
    
End Sub		
		


ユーザーフォームにハイパーリンクを設定したいとき

ワークシートと同じようにユーザーフォームにもハイパーリンクを設定する方法です。
ネット上のウェブサイトにリンクを張る方法は、他の場所でも紹介されているようですが、ワークシートにリンクを張る例があまり見当たらなかったので記しておきます。
次のサンプルではSheet1のA100セルにリンクを張っています。
ユーザーフォーム上にラベル1を配置し、クリックイベントに記述します。
ただし、ラベル上にマウスがあってもポインタは指マークには変化しません!
Private Sub Label1_Click()
'ワークシート上のセルにリンク
  ThisWorkbook.FollowHyperlink Address:=ThisWorkbook.Path _
       & "\" & ThisWorkbook.Name, SubAddress:="Sheet1!A100"
End Sub
		


生年月日から年齢を計算したいとき

生年月日から年齢を計算するときは、DateDiff関数を使うのが便利でしょう。
注意しなければいけないのは、そのまま使うと結果が満年齢では返ってこない点です。
誕生日前であっても誕生日が過ぎたものとして年齢が計算されてしまいます。
このため、ここでは誕生日の月日と基準日の月日とを比較して、基準日が誕生日の前になっている場合は1を引いています。
サンプルでは基準日が誕生日と同じ日ですので、8が返ります。
仮に誕生日が"1999/07/02"だと、7が返ることになります。
もちろん基準日は今日の日付にすることもできます。
DateDiff関数の引数の与え方については、VBAのヘルプを参照してください。
Public Sub nenrei()
    Dim birth As String
    Const KIJUN As String = "2007/07/01"
    birth = "1999/07/01"
    If Format(birth, "mm/dd") > Format(KIJUN, "mm/dd") Then
        Range("A1").Value = DateDiff("yyyy", birth, KIJUN) - 1
    Else
        Range("A1").Value = DateDiff("yyyy", birth, KIJUN)
    End If
End Sub
		


OnActionプロパティを使って、実行マクロに引数を渡したいとき

OnActionプロパティを使うと、オブジェクトがクリックされたときに実行するマクロを設定できますが、同時に引数も渡したいときがあります。
例えば挿入した画像をクリックしたときに、その画像のオブジェクト名をいっしょに渡したい (Selection.OnAction = "Macro1" & オブジェクト名 としたい…)場合です。
引数がリテラル(プログラムの中に直接記述できる値のこと、定数)の場合は、例えば次のように記述すれば動きます。

【例1】 Selection.OnAction = "'Macro1 ""ABC""'"(Macro1にABCを渡す)

では変数を渡したい場合はどうすればよいでしょうか?
これは私も試行錯誤の上探し当てたのですが、【例2】のようにすれば問題なく動きました。
もっと簡潔にしたかったのですが、分かりませんでした。
今のところ自分では一応これでOKということにしています。
【例2】Selection.OnAction = "'Macro1 " & """" & 変数 & """" & "'"
		


セルサイズに画像のサイズを合わせたいとき

画像をシートに挿入するマクロと組み合わせて使うと便利です。
下記のプロシージャは画像サイズをセルの幅または高さに合わせるマクロのサンプルです。
ここでは拡大・縮小の際に常にセル内に画像が納まるように、高さと幅の比を計算し、長さが小さい方にサイズを合わせるようにしています。
また、デフォルトで設定されているようですが、Selection.ShapeRange.LockAspectRatio = msoTrueを明示して、拡大・縮小時に高さと幅の比率が常に一定になるようにしています。
Public Sub SetPicSize()

    Dim Cell_H As Single
    Dim Cell_W As Single
    Dim Cell_Ratio As Single
    Dim Obj_Ratio As Single
    

    'セルの幅と高さを取得
    With Range("A1")
        Cell_H = .Height
        Cell_W = .Width
        Cell_Ratio = .Height / .Width     '高さ/幅
    End With
    
    '画像をセルの幅または高さに合わせる
    ActiveSheet.Shapes("Picture 1").Select
    With Selection.ShapeRange
        .LockAspectRatio = msoTrue      '一定比率
        Obj_Ratio = .Height / .Width
        If Cell_Ratio > Obj_Ratio Then
            'セル枠の方が高さの比が大きい(セル幅に合わせる)
            .Width = Cell_W
        Else
            'セル枠の方が高さの比が小さい(セル高に合わせる)
            .Height = Cell_H
        End If
    End With
    
End Sub
		


配列を初期化したいとき

配列をプログラムの途中で0や""で初期化する場合、For〜Nextで値を代入する方法と、Eraseステートメントでクリアする方法があります。
Eraseステートメントについては、VBAのヘルプに詳しく説明されていますので、以下にそれをそのまま掲載しておきます。

Eraseステートメントは固定サイズの配列の場合は要素を再初期化し、動的配列の場合は割り当てたメモリを解放します。 Eraseの横には、消去する配列変数を指定し、複数指定する場合は、カンマ (,) で区切ります。
配列が固定サイズの配列 (通常の配列) であるか、または動的配列であるかによって、Erase ステートメントの動作は異なります。 固定サイズの配列の場合、Erase ステートメントはメモリを解放せずに各要素を次のように設定します。

静的数値配列 →要素はすべて0に設定
静的文字列配列 (可変長) →要素はすべて長さ0の文字列("")に設定
静的文字列配列 (固定長) →要素はすべて0に設定
静的バリアント型 (Variant) 配列 →要素はすべてEmpty値に設定
ユーザー定義型配列 →各要素は、別個の変数として設定
オブジェクト配列 →要素はすべて特別な値Nothingに設定

動的配列の場合はその配列が使っていたメモリを解放します。
そのためプログラムでこの配列を再度参照するには、ReDim ステートメントを使って、配列の次元を再宣言する必要があります。
		例1)
			For i=0 to UBound(ar)
			    ar(i)=0
			Next i
		例2) 
			Erase ar
		


ファイルのコピーと削除をVBAで実行したいとき

VBAでファイルをコピーしたり、削除したりする例です。
ここではテキストファイルのみに対して操作可能にしています。
ときにはコピー先のファイル名を変更したい場合もあるかもしれません。目的に合わせてアレンジしてみてください。
なおファイルコピーは、コピー先に同名のファイルが存在する場合は、そのままコピー元の内容で上書きされてしまいますので注意してください。
SelectedFileCopy及びSelectedFileDeleteを、ワークシートにボタンを貼り付けるなどして呼び出せば実行可能です。
Public Sub SelectedFileCopy()
'フィルのコピー

    Dim sFrom As String
    Dim sTo As String
    Dim msg As String
    Dim tmp As String
    
    
    'コピー元指定
    msg = "コピー元ファイルを指定してください"
    sFrom = Application.GetOpenFilename("テキストファイル,*.txt", , msg)
    If StrConv(sFrom, vbUpperCase) = "FALSE" Then
        MsgBox "キャンセルされました。"
        Exit Sub
    End If
    
    'ファイル名を取り出す
    tmp = NameFromPath(sFrom)
    
    'コピー先指定
    msg = "コピー先フォルダを指定してください"
    sTo = GetFolder(msg)
    sTo = sTo & "\" & tmp

    'ファイルのコピー
    FileCopy sFrom, sTo
    
    MsgBox sFrom & "を" & sTo & "にコピーしました。"
    
End Sub

Public Sub SelectedFileDelete()
'ファイルの削除

    Dim sDell As String
    Dim msg As String
    
    
    '削除ファイル指定
    msg = "削除ファイルを指定してください"
    sDell = Application.GetOpenFilename("テキストファイル,*.txt", , msg)
    If StrConv(sDell, vbUpperCase) = "FALSE" Then
        MsgBox "キャンセルされました。"
        Exit Sub
    End If

    'ファイルの削除(ゴミ箱には入らないので注意)
    Kill sDell
    
    MsgBox sDell & "を削除しました。"

End Sub

Public Function GetFolder(msg As String) As String
'ダイアログを開いて、選択フォルダのパスを返す

    Dim WSH
    Dim FolPath
    
    
    Set WSH = CreateObject("Shell.Application")
    Set FolPath = WSH.BrowseForFolder(0, msg, 0)
    
    If Not FolPath Is Nothing Then
        '[OK]
        GetFolder = FolPath.items.Item.Path
    Else
        '[Cancel]
        GetFolder = ""
    End If
    
End Function

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 Sub GetLdForm()

    Dim fm As Object
    
    For Each fm In UserForms
        MsgBox fm.Name & vbCrLf & fm.Caption
    Next

End Sub
		


ワークシートにイベント処理を記述したくないとき

ワークシート上でクリック、ダブルクリックなどのイベントが発生したときに、ワークシートに直接イベント処理を記述しないで、別モジュールに記述する方法を説明します。
特定ワークシートを単なる資料として保存したいようなときに便利です。
該当シートのみを単独で保存した場合、毎回「マクロを有効にする」かの問合せがなくなるので、わずらわしさが軽減します。
まずThisWorkbookモジュールのWorkbook_Open()イベントに@を記述します。
次に標準モジュールModule1にAを書いてください。
そのまま保存をして再度起動すると、Sheet1のA1・B1・C1をダブルクリックしたときのみ、マクロが実行されます。
Private Sub Workbook_Open()
'@
    ActiveWorkbook.Worksheets("Sheet1").OnDoubleClick = "Test"
    
End Sub

Public Sub Test()
'A
    Select Case ActiveCell.Address
        Case "$A$1"
            MsgBox "A1がダブルクリックされました。"
        Case "$B$1"
            MsgBox "B1がダブルクリックされました。"
        Case "$C$1"
            MsgBox "C1がダブルクリックされました。"
    End Select

End Sub
		


空白を含む文字列からすべての空白を取り除きたいとき

空白を取り除く関数にTrim()、LTrim()、RTrim()関数がありますが、Trim()関数でも文字列の両端の空白を取り除くことしかできません。
文字列の中に含まれる空白(半角、全角)を取り除くために作ったものが以下のコードです。
単純ですが便利です。
Public Function SpaceOff(dt As String) As String

    Dim tmp As String
    Dim Aftr As String
    Dim i As Integer
    
    For i = 1 To Len(dt)
        tmp = Mid(dt, i, 1)
        If tmp <> " " And tmp <> " " Then
            Aftr = Aftr & tmp
        End If
    Next i
    SpaceOff = Aftr
    
End Function
		


一定間隔でマクロを実行させたいとき

一定間隔でマクロを実行させる場合は、次の記述が有効かもしれません。
当然マクロで何をさせるのかによって、有効な場合とそうでない場合があると思いますので、使用する際は注意してください。
次の例は10秒間隔でセルに現在時刻の表示を更新させるものです。
このような類の場合は、便利だと思います。
まずマクロ起動時に、現在から10秒後にプロシージャ"Proc1"を実行せよとのコードを記述します。
OnTimeメソッドは、指定された時刻にプロシージャを実行する命令です。
現在の時刻から指定時間が過ぎてから、処理を実行させたいときは、後ろにNow + TimeValue(time) と付加します。
指定した特定の時刻に処理を実行させるときは、TimeValue(time) を使います。
例 9時にProc1を実行:Application.OnTime TimeValue("09:00:00"), "Proc1"
いったんProc1が実行されると、Proc1の処理の中で再び自分自身を呼び出す「Application.OnTime Now + TimeValue("00:00:10"), "Proc1"」の記述があるため、再帰的に無限に繰り返されることになります。

または単純に一定間隔でループを行わせるだけなら、Waitメソッドを使ったほうがよいかもしれません。A参照

@
Private Sub Proc1()

    Range("A1") = Format(Now, "hh:mm:ss")
    '(メインの処理を記述/例:セルに時刻表示)

    ' 次の処理の起動準備をする
    Application.OnTime Now + TimeValue("00:00:10"), "Proc1"
    
End Sub

Private Sub auto_open()

    '開始時に10秒後の起動設定を行う
    Application.OnTime Now + TimeValue("00:00:10"), "Proc1"
 
End Sub

A単純にループを一定間隔で実行する場合
Public Sub sample()
    Dim i As Long
    Dim strT As String
    '待ち時間を秒で指定
    strT = Format(Range("B1").Value, "00")
    '指定間隔でA1にカウント表示
    For i = 9 To 0 Step -1
        Range("A1").Value = i
        Application.Wait Now + TimeValue("00:00:" & strT)
        DoEvents	'省略するとループ実行の間は操作を受け付けなくなります
    Next i
End Sub

		


ワークシート関数と同等のRound 関数を使用したいとき

マイクロソフトサイトに「VBAのRound 関数は、Excelワークシート関数のRoundと異なる結果となる場合があります。」との記述があります。
具体的には、ワークシート関数のRound は"算術型" (通常の四捨五入)の丸め処理を行いますが、VBAのRound関数は"銀行型" の丸め処理を行い、".5" は、結果が偶数になるように丸め処理が行われ、切り上げられることも、切り捨てられることもありえます。
したがってワークシート関数と同じ機能のRound 関数を使用したい場合は、次のようにWorksheetFunctionプロパティを使用するのがよいようです。
以下の例では、@の式ではxに8が格納されますが、Aではxに9が格納されます。
y = 8.5
x = Round(y, 0)		'@
MsgBox x
x = Application.WorksheetFunction.Round(y ,0)	'A
MsgBox x
		


値貼り付けを簡潔にコーディングしたいとき

ある範囲のデータを値貼り付けでコピー&ペーストする場合、“形式を選択して貼り付け”で“値”を選択すると、マクロ記録では【1】のコードが作成されます。
このままでも再実行できますが、簡潔、高速にするためSelectメソッドをはずすされる方も多いと思います。【2】値貼り付けでなければ1行にまとめることも出来ます。
さらに【3】のようにcopyメソッドを使わずに、範囲をバリアント型変数に格納し、そのままコピー先の場所に代入すると、選択範囲を解除する必要もなくなります。
【1】
Sub Macro1()
    Range("A1:A10").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

【2】※値貼り付けでなければ
   Range("A1:A10").Copy Sheets("Sheet2").Range("C1") がよいでしょう。
Sub Macro2()
    Range("A1:A10").Copy
    Sheets("Sheet2").Range("C1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End Sub

【3】
Public Sub copytest()
    Dim ar As Variant
    ar = Range("A1:A10").Value
    Worksheets("Sheet2").Range("C1:C10").Value = ar
End Sub
		


オブジェクトのセル番地を取得したいとき

この場合はTopLeftCellプロパティを使用します。
下記はワークシート上にコマンドボタンやチェックボックスなどのオブジェクトを配置したとき、そのオブジェクトをクリックした際、配置下のセル番地を取得する場合のコード例です。
複数のセルにまたがって配置した場合には、オブジェクトの左上端のアドレスとなります。
ただしコントロールツールボックスで配置したオブジェクトに限ります。 フォームオブジェクトでは機能しません。
Private Sub CommandButton1_Click()
    MsgBox CommandButton1.TopLeftCell.Row
    MsgBox CommandButton1.TopLeftCell.Column
    MsgBox CommandButton1.TopLeftCell.Address
End Sub
		


シートに保護がかかっているかどうか調べたいとき

現在のワークシートに保護がかかっているかどうかは、WorksheetのProtectContentsプロパティで判定することが可能です。
Trueが返って来たら、シートの内容は保護されていることになります。
Public Sub CheckProtect()
'シート保護の識別

    If ActiveSheet.ProtectContents Then
        MsgBox "シート保護されています。"
    Else
        MsgBox "シート保護されていません。"
    End If
    
End Sub
		


スクロールエリアを制限したいとき

例はセル番地B2からJ43以外の場所へのスクロールを制限します。
セル選択もできなくなります。
解除する場合はScrollAreaプロパティに空の文字列 ("") を設定します。
Worksheets("Sheet1").ScrollArea="B2:J43" または
Worksheets(1).ScrollArea="B2:J43"
		


押されたボタンの名前を取得したいとき

フォームツールバーで作成したボタンを押したときの、そのボタン名を取得するためのコードです。
サンプルを応用すれば似たようなボタンが複数あるとき、ボタン名をパラメータとしてプロシージャに渡してあげることで共通の処理をさせることができます。
次のサンプルはExcelメニューバーから「表示」→「ツールバー」→「フォーム」でワークシート上にボタンを作成し、マクロの登録で標準モジュール上に作成した「DspBunntonName」に関連付けた場合、押されたボタン名を表示します。
Public Sub DspBunntonName()

    '押されたボタンの名前を表示
    MsgBox Application.Caller
    
End Sub
		


複数オブジェクトを選択したいとき

ワークシート上に複数配置されたオートシェイプのうち、任意のものを選択する方法です。
手作業ではコントロールキーを押しながら1つずつ選択していくか、マウスで範囲をドラッグして一挙に選択する操作に該当します。
Selectメソッドでオブジェクトを選択し直す場合は後ろに true(省略可)、現在の選択内容に既に選択されているオブジェクトを追加する場合は false を記述します。
Sub SelectObj_1()
'複数オブジェクトの選択例1

    With ActiveSheet
        .Shapes("Rectangle 1").Select
        .Shapes("Rectangle 2").Select False
        .Shapes("Rectangle 3").Select False
    End With
End Sub

Public Sub SelectObj_2()
'複数オブジェクトの選択例2

    ActiveSheet.Shapes.Range(Array("Rectangle 1", _
                                    "Rectangle 2", _
                                    "Rectangle 3")). _
                                    Select  
End Sub
		


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

ワークシートのシート名ではなく、コード名(オブジェクト名)を知るにはCodeNameプロパティを調べます。
CodeNameプロパティはオブジェクトのコード名を返します。
また、シート名を調べる場合はNameプロパティを調べます。
シートの作成時はシート名とコード名は同じですが、シート名とコード名は別な名前に変更できるので、そういう場合はこれらプロパティで調べるとそれぞれの名前が分かります。
MsgBox "オブジェクト名= " & ActiveSheet.CodeName
MsgBox "シート名= " & ActiveSheet.Name
		


入力後のセル移動を変更したいとき

以下は、ワークシートによって、入力後のセルポインタの移動方向を変更する場合のサンプルです。
シートが選択されたとき、Sheet1の場合は右へ移動するように変更し、Sheet1以外は下への移動に戻ります。(シート名で判定する場合はNameプロパティで比較してください)
サンプルではワークブックを閉じたときに、BeforeCloseイベントで必ず下への移動に戻るようにしていますが、通常の移動方向を「下へ」以外にしている場合はその状態に戻してください。
Private Sub Workbook_BeforeClose(Cancel As Boolean)

    '入力後のセル移動を[下へ]に変更
    With Application
            .MoveAfterReturn = True
            .MoveAfterReturnDirection = xlDown
    End With
        
End Sub

Private Sub Workbook_Open()

    Sheet1.Activate
    
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    'WorkSheetのオブジェクト名を判定
    If Sh.CodeName = "Sheet1" Then
        '入力後のセル移動を[右へ]に変更
        With Application
            .MoveAfterReturn = True
            .MoveAfterReturnDirection = xlToRight
        End With
    Else
        '入力後のセル移動を[下へ]に変更
        With Application
                .MoveAfterReturn = True
                .MoveAfterReturnDirection = xlDown
        End With
    End If

End Sub
		


フォルダ内のファイル名をリスト表示

次のサンプルは、マクロが置かれているフォルダ内のファイル一覧を、リストボックスに表示するコードです。
ファイルの拡張子「.xls」のみをリストボックスに追加していきます。
自身のファイル名は不要なので、ThisWorkbook.Nameで名前を確認してはずすようにしています。
Dir()ではパスを除いたファイル名だけが帰ってくるので便利です。
    Dim buf As String
    buf = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
    Do While buf <> ""
        If buf <> ThisWorkbook.Name Then
            ListBox1.AddItem buf
        End If
        buf = Dir()
    Loop
		


レベル制御(小計の出力)を行いたいとき

コード(A列)の先頭1文字が変わったら、そこまでの小計を出力するサンプルです。
下図のデータ(A列〜B列)を集計し、D、E列に書き出します。

Public Sub sample()
    Dim i As Long               '入力行
    Dim j As Long               '出力行
    Dim sCode As String
    Dim ttl As Variant
    Dim sum_ttl As Variant
    Dim endRow As Long
    'データをA列でソート
    endRow = Range("A65536").End(xlUp).Row
    Range("A1:B" & endRow).Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=True
    Range("A1").Select
    '集計列をクリア
    Range("D1:E65536").ClearContents
    '集計処理
    i = 1: j = 1
    sCode = Left(Cells(i, 1).Value, 1)
    Do While Cells(i, 1).Value <> ""
        If sCode <> Left(Cells(i, 1).Value, 1) Then
            '小計出力
            Cells(j, 4).Value = "-- 小計 --"
            Cells(j, 5).Value = ttl
            ttl = 0
            j = j + 2
        End If
        '明細出力
        Cells(j, 4).Value = Cells(i, 1).Value
        Cells(j, 5).Value = Cells(i, 2).Value
        ttl = ttl + Cells(i, 2).Value
        sum_ttl = sum_ttl + Cells(i, 2).Value
        sCode = Left(Cells(i, 1).Value, 1)
        i = i + 1
        j = j + 1
    Loop
    '最後グループの小計出力
    Cells(j, 4).Value = "-- 小計 --"
    Cells(j, 5).Value = ttl
    j = j + 2
    '総計出力
    Cells(j, 4).Value = "-- 総計 --"
    Cells(j, 5).Value = sum_ttl
End Sub
		


一時的にプリンタを変更する

VBAから今印刷しようとしている出力先プリンタを変更する場合の例です。
ActivePrinterで印刷しようとするプリンタ名を指定します。
ネットワーク上のプリンタを使用していたり、他のパソコンに接続されているプリンタを使用している場合などで、ポート番号が変化するために印刷がうまく実行されない場合は、プリンタ名後半の「on NeXX:」部分を削除して指定してください。
なお変更したままでは後の操作に支障がでるような場合は、マクロ起動時に現在のプリンタ名を取得しておき、印刷後に元にもどしておきます。
Public DefaultPrinter As String
Public Sub Print()
'一時的にプリンタを変更する
    ActiveSheet.PrintOut _
                Copies:=1, _
                ActivePrinter:="Canon BJ S300 on Ne03:", _
                Collate:=True
'デフォルトプリンタに戻す
Application.ActivePrinter = DefaultPrinter
End Sub

Private Sub Workbook_Open()
    '現在のプリンタ名を記憶
    DefaultPrinter = Application.ActivePrinter
End Sub
		


ファンクションキーに任意のマクロを割り当てたいとき

F1,F2,F3...のようなファンクションキーに任意のプロシージャ/関数を割り当てると、メニューからマクロを実行したり、ボタンを設置したりしなくて済むので便利かもしれません。
ただし普段マウスでの操作しかしないのであれば、かえって不便かもしれません。
そのときの使用状況に合わせて考えてみてください。
VBAコードはいたって簡単です。
標準モジュールにあらかじめ"test1"や"test2"などのプロシージャを作成しておき、ファイル起動時にF1やF2キーに、Application.OnKeyメソッドでそれぞれのプロシージャを割り当てておきます。
Private Sub Workbook_Open()

    Application.OnKey "{F1}", "test1"
    Application.OnKey "{F2}", "test2"

End Sub
		


固定長レコードを読み込みたいとき

読み込むファイルが固定長データの場合、各項目の長さが決まっているため、 読み込んだデータを各項目の長さで切り分けて、それをセルまたは変数に格納する 方法を取ります。

データを各項目の長さごとに分割する場合、まずMid関数(またはMid$関数)を利用する方法を思いつきますが、 文字単位で位置をカウントする場合、全角、半角が混じったデータだとうまくいきません。
そこでMidB関数(またはMidB$関数)を使って、バイト単位でカウントすることにします。
ここで注意しなければならないのがVBAはUnicodeを採用しているので、文字コードが16ビット(2バイト)単位であることです。 つまり例え日本語文字が1文字であっても、Unicodeでは2バイトで表現されていることになります。
このままだと位置や長さの計算が不便なので、いったんANSIコード(1文字=8ビット/1バイト)に変換して、処理後にUnicodeに戻す処理を行わせています。
    '【レコード内の各項目の位置(長さ)】
    ' 1-16(16) :名前
    '17-36(20) :読み
    '37-44(08) :生年月日
    '45-45(01) :性別
    '------------------------------------

Sub ReadData()
   Dim FSO As Object                               'FileSystemObject
   Dim TSO As Object                               'TextStream
   Dim inREC As String                             'データ
   Dim FilePath As String                          'ファイルパス
   Dim r As Long                                   '出力行
   Const DATA_FILE As String = "\fxData.txt"

   FilePath = ThisWorkbook.Path & DATA_FILE
   Set FSO = CreateObject("Scripting.FileSystemObject")    
   r = 1
   Set TSO = FSO.GetFile(FilePath).OpenAsTextStream
   With TSO
       Do Until .AtEndOfStream
           inREC = StrConv(.ReadLine, vbFromUnicode)
           Cells(r, 1).Value = StrConv(MidB$(inREC, 1, 16), vbUnicode)
           Cells(r, 2).Value = StrConv(MidB$(inREC, 17, 20), vbUnicode)
           Cells(r, 3).Value = StrConv(MidB$(inREC, 37, 8), vbUnicode)
           Cells(r, 4).Value = StrConv(MidB$(inREC, 45, 1), vbUnicode)
           r = r + 1
       Loop
       .Close
   End With
End Sub
		


●選択したオブジェクトのみを処理する

ワークシート上の全オブジェクトについて、何か処理する場合は@のようにFor Eachでまわしてやればできますが、 選択したオブジェクトだけに対して何か処理したい場合は、なかなかうまい方法が見つかりません。
ここではAのようにしてTypeNameを実行したときに返ってくる値を利用して判定しています。
例えばシートに貼り付けてある画像を1個選択している場合は"Picture"が返りますが、2個以上を選択している場合は "DrawingObjects"が返ります。このことを利用してIF文で処理を分岐させています。
Public Sub @全オブジェクトを処理()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        MsgBox shp.Name
    Next shp
End Sub

Public Sub A選択オブジェクトを処理()
    Dim obj As Object
    If TypeName(Selection) = "Picture" Then
        MsgBox "選択されているオブジェクト名は" & Selection.Name, , "1枚選択"
    ElseIf TypeName(Selection) = "DrawingObjects" Then
        For Each obj In ActiveSheet.DrawingObjects
            MsgBox "選択されているオブジェクト名は" & obj.Name, , "複数選択"
        Next obj
    Else
        MsgBox "画像を選択してください。", , "選択なし"
    End If
End Sub
		


●自作のメンバーリストを作成して、定数を入力する

あることに関係する一連の定数がたくさんあったとします。それを個々にConstステートメントで宣言してもよいですが、定数を列挙型で宣言すると、入力する際にメンバーリストからの入力ができて楽です。
それがEnumステートメントを使った宣言方法です。(ただし長整数型のみです)
下記の例は、あまり意味のあるコードではありませんが、利用方法を示すために載せています。
Option Explicit

'立方体の各辺の長さ
Public Enum pCube
    	    pC_Tate = 10
    	    pc_Yoko = 15
    	    pc_Takasa = 7
End Enum

Public Sub Sample()

    Dim cb1 As pCube
    Dim cb2 As pCube
    Dim cb3 As pCube
    Dim myVolume As Long
    
    
    cb1 = pc_Takasa
    cb2 = pC_Tate
    cb3 = pc_Yoko
    myVolume = cb1 * cb2 * cb3
    MsgBox myVolume
    
End Sub
		


●セル値を文字列と数字に分離する

1つのセルに文字列と数字が混ざって入力されているとき、それを文字列と数字に分けなければいけないことは、ときどきあります。
何かのコードのような場合は、それぞれの桁数があらかじめ決まっており、位置も固定なのでそれほど苦労せずに分離できると思います。
しかし、中にはランダムに文字列と数字のかたまりが入力されており、とにかくその文字列と番号(数字)を分けなくてはいけないことがあるかもしれません。
そのようなとき、次のマクロは役に立つと思います。
Public Sub 文字と数字に分割()

    Dim Letter(5) As String
    Dim Number(5) As String
    Dim i As Long
    
    
    Call LMSplit(Letter, Number)
    
    For i = 0 To UBound(Letter)
        If Letter(i) = "" Then Exit For
        Debug.Print Letter(i)
    Next i
    For i = 0 To UBound(Number)
        If Number(i) = "" Then Exit For
        Debug.Print Number(i)
    Next i
    
End Sub
		
Public Sub LMSplit(Letter() As String, Number() As String)
'文字/数字分割マクロ

    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim myData As String
    Dim xx As String
    Dim LetBuf As String
    Dim NumBuf As String
    Dim bNum As Boolean
    
    
    myData = Range("A1").Value
    For i = 1 To Len(myData)
        xx = Mid(myData, i, 1)
        If xx Like "[0-9]" Then
            '数字
            If Not bNum And i > 1 Then
                Letter(k) = LetBuf
                LetBuf = ""
                k = k + 1
            End If
            NumBuf = NumBuf & xx
            bNum = True
        Else
            '文字
            If bNum Then
                Number(j) = NumBuf
                NumBuf = ""
                j = j + 1
            End If
            LetBuf = LetBuf & xx
            bNum = False
        End If
    Next i
    
    'Last
    If LetBuf <> "" Then
        Letter(k) = LetBuf
    End If
    If NumBuf <> "" Then
        Number(j) = NumBuf
    End If
    
End Sub
		


 


office boole banner 長崎県長崎市 Office Boole 末永 尚登
E-mail: suenaga@officeboole.com   TEL/FAX: 095-893-6090