HOME > エクセルVBA > Tips

Tips


【ダウンロード】Tips.zip
【動作環境】Windows Vista Excel 2007 (97-2003形式で保存)
【作成日】2009年04月12日
【更新日】2015年05月13日

ブラウザで見る場合はTips.xlsのソースをご覧ください。

補足
  Debug.PrintはVisual Basic Editorのイミディエイトウィンドウに表示します。

アプリケーション Application

画面の更新を止め、マクロの速度を向上 Application.ScreenUpdating

マウスポインタの形状を設定 Application.Cursor

EscキーあるいはCtrl + Breakキーによる、割り込みの処理 Application.EnableCancelKey

ショートカットキーを登録し、プロシージャを実行 Application.OnKey

警告やメッセージを表示しない Application.DisplayAlerts

イベントを発生させない Application.EnableEvents

Excelのワークシート関数を使う Application.WorksheetFunction

文字列の式を計算する Application.Evaluate

ユーザ関数の定義の分類に追加 Application.MacroOptions

組み込みダイアログを表示 Application.Dialogs

ファイルを開くダイアログ Application.GetOpenFileName

エクセルのバージョン Application.Version


ブック Workbook

開いているワークブックの名前を表示する

指定したワークブックをエクセルで開いているか?

ブックを開いたときに実行 Workbook_Open


シート

アクティブブックのすべてのシートの名前を表示する

アクティブワークブックに指定したシートがあるか?

アクティブワークブックに表示しているシート数を取得する


セル Range

すべてのセルを選択する Cells.Select

アクティブセル領域(空白行と空白列で囲まれたセル範囲)を選択する CurrentRegion

指定した条件のセルを選択する SpecialCells

使われたセル範囲を選択する UsedRange

指定した列の入力されている最終行に移動する End(xlUp)

セル範囲の集合(Union)と共有セル範囲(Intersect)

セルのオフセット(Offset)とセル範囲の変更(Resize)

選択しているのはセルか? Selection

隣接しない複数の選択範囲 Areas

セルを含む列を取得 EntireColumn


その他

イミディエイトウィンドウに出力 Debug.Print

Format関数で数字の先頭に0を付ける

変数の宣言を強制 Option Explicit

キーコードを転送 SendKeys

文字列の変換(小文字、大文字、先頭のみ大文字、半角、全角、カタカナ、ユニコード) StrConv

ブックのドキュメントプロパティの取得 BuiltinDocumentProperties

プログラムを実行 Shell

エクセルファイルの一覧を表示する Dir

エラー処理 On Error

プロシージャの引数の省略 Optional IsMissing

すべてのオブジェクトを削除 Shapes.SelectAll Selection.Delete

メニューの追加 Application.CommandBars

すべてのブックで使える[個人用マクロ ブック]  Personal.xlsb

すべてのメニューバーとツールバーをリセットする(使用者が作成した場合は削除) Application.CommandBars


アプリケーション Application

画面の更新を止め、マクロの速度を向上 Application.ScreenUpdating
  Application.ScreenUpdating = True


このページの上

マウスポインタの形状を設定 Application.Cursor
' XlMousePointer 列挙
  Application.Cursor = xlDefault        ' 標準のポインタ
  Application.Cursor = xlIBeam          ' i 字型ポインタ
  Application.Cursor = xlNorthwestArrow ' 矢印型ポインタ
  Application.Cursor = xlWait           ' 砂時計型ポインタ

このページの上

EscキーあるいはCtrl + Breakキーによる、割り込みの処理 Application.EnableCancelKey
  Application.EnableCancelKey = xlDisabled     ' 割り込みを無視
  Application.EnableCancelKey = xlErrorHandler ' エラーを送り、 On Error GoTo ステートメントでトラップできます。エラーコードは18
  Application.EnableCancelKey = xlInterrupt    ' デバッグ、終了などを行えるように、実行中のプロシージャを停止

このページの上

ショートカットキーを登録し、プロシージャを実行 Application.OnKey
  Application.OnKey "キーの文字列", "プロシージャ名"
 キーの文字列の英字は小文字を使います。
 Shiftは + (正符号)
 Ctrlは ^ (カレット)
 Altは % (パーセント記号)
 {HOME}、{END}、{LEFT}、{RIGHT}、{UP}、{DOWN}、{INSERT}、{DELETE} 、{RETURN}、{F1} 〜 {F15}など詳細はヘルプを参照してください。
' 初期処理
Sub Auto_Open()
' 初期処理
Sub Auto_Open()
  Application.OnKey "^m", "OnNowClick" ' ショートカットキーの登録 [Ctrl]+[M]
End Sub

' 今日の日付と今の時間の表示
Sub OnNowClick()
  MsgBox Prompt:=Now(), Buttons:=vbInformation, Title:="今日の日付と今の時間"
End Sub

' 終了処理
Sub Auto_Close()
  Application.OnKey "^m" ' ショートカットキーの取り消し
End Sub

このページの上

警告やメッセージを表示しない Application.DisplayAlerts
  Application.DisplayAlerts = False ' 警告やメッセージを表示しない

このページの上

イベントを発生させない Application.EnableEvents
  Application.EnableEvents = False ' イベントを発生させない
  
  Application.Wait Now + TimeValue("00:00:05") ' 5秒間待つ
  
  Application.EnableEvents = True ' イベントが発生します

このページの上

Excelのワークシート関数を使う Application.WorksheetFunction
  一部のワークシート関数は使えません。
  WorksheetFunctionで使えない関数は、Application.Evaluateを使います。
  Debug.Print Application.WorksheetFunction.Dec2Hex(13) ' 10進数の13は16進数ではD

このページの上

文字列の式を計算する Application.Evaluate
 エクセルのバージョンにより実行できない関数があります。
  Debug.Print Application.Evaluate("Code(" & """A""" & " )") ' A=65

このページの上

ユーザ関数の定義の分類に追加 Application.MacroOptions
 MacroOptionsを使い、引数のMacroに関数名を、引数のCategoryに「関数の分類」を、引数のDescriptionに説明を指定します。
 ユーザー定義関数の中でVolatileを使い、いずれかのセルで計算が行われるたびに再計算させます。
'===========================================================
' ユーザー定義関数の登録
'===========================================================
Private Sub RegistMacro()
  Const csCategory = "私の関数"
  Dim Str As String

  On Error Resume Next ' アドインの場合は「MacroOptions」でエラーになるため

  Str = "指定した年から閏年か判定する"
  Application.MacroOptions Macro:="閏年", Description:=Str, Category:=csCategory, StatusBar:=Str

  Str = "干支を取得する"
  Application.MacroOptions Macro:="干支", Description:=Str, Category:=csCategory, StatusBar:=Str

  Str = "月末日を取得する"
  Application.MacroOptions Macro:="月末日", Description:=Str, Category:=csCategory, StatusBar:=Str

  On Error GoTo 0
End Sub
'===========================================================
' 指定した年から閏年か判定する
'===========================================================
Public Function 閏年(年 As Long) As Boolean
  Application.Volatile ' いずれかのセルで計算が行われるたびに再計算を行う
  閏年 = ((年 Mod 400) = 0) Or (((年 Mod 100) <> 0) And ((年 Mod 4) = 0))
End Function
'===========================================================
' 干支を取得する
'===========================================================
Public Function 干支(年)
  Application.Volatile ' いずれかのセルで計算が行われるたびに再計算を行う
  干支 = Mid("申酉戌亥子丑寅卯辰己午未", (年 Mod 12) + 1, 1)
End Function

 上記のサブルーチンのRegistMacroを実行すると、関数の挿入のダイアログが下記のように表示されます。
関数の挿入ダイアログ
このページの上

組み込みダイアログを表示 Application.Dialogs
  Application.Dialogs(xlDialogSelectSpecial).Show ' [条件を選択してジャンプ]の[選択オプション]ダイアログを表示

このページの上

[ファイルを開く]ダイアログ Application.GetOpenFileName
  [ファイルを開く]ダイアログで選択した複数のファイル名を、イミディエイトウィンドウに出力します。
 Application.GetOpenFileNameはファイル名を取得するだけで、ファイルは開きません。
  Dim fn As Variant ' ファイル名の一覧
  Dim i As Long

  fn = Application.GetOpenFilename(FileFilter:=" エクセルのファイル(*.xl*),*.xl*, すべてのファイル (*.*),*.*", Title:="ファイルの選択", MultiSelect:=True)
  If VarType(fn) = vbBoolean Then Exit Sub ' [Cancel]ボタンを押したら終了
  For i = LBound(fn) To UBound(fn)
    Debug.Print fn(i)
  Next i

  Application.VBE.Windows("イミディエイト").Visible = True ' イミディエイトウィンドウを表示します。
Application.GetSaveAsFilenameは[名前を付けて保存] ダイアログ ボックスを表示してファイル名を取得します。

下記は[ファイルを開く]ダイアログを表示して、選択したファイルを開きます。
  Application.Dialogs(xlDialogOpen).Show


下記は日付のファイル名を代入した[名前を付けて保存]ダイアログを表示します。
  Dim FileName As String

  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了
  FileName = Format(Now(), "Long Date") ' YYYY年M月D日
  Application.Dialogs(xlDialogSaveAs).Show , FileName ' 日付のファイル名を代入して[名前を付けて保存]ダイアログを表示

このページの上

エクセルのバージョン Application.Version
 下記はイミディエイトウィンドウにエクセルのバージョンを表示します。
Private Function GetExcelVersion() As String
  Select Case CInt(Application.Version)
    Case Is = 16
      GetExcelVersion = "2016"
    Case Is = 15
      GetExcelVersion = "2013"
    Case Is = 14
      GetExcelVersion = "2010"
'    Case Is = 13 ● 13は不吉な数字なので存在しません
    Case Is = 12
      GetExcelVersion = "2007"
    Case Is = 11
      GetExcelVersion = "2003"
    Case Is = 10
      GetExcelVersion = "2002"
    Case Is = 9
      GetExcelVersion = "2000"
    Case Is = 8
      If InStr(Application.OperatingSystem, "Windows") > 0 Then
        GetExcelVersion = "97" ' Windowsは97
      Else
        GetExcelVersion = "98" ' Macの場合は98
      End If
    Case Is = 7
      GetExcelVersion = "95"
    Case Is = 5
      GetExcelVersion = "5.0"
    Case Else
      GetExcelVersion = "不明 " & Application.Version
  End Select
End Function
'
Sub PrintExcelVersion()
  Debug.Print "Excel " & GetExcelVersion()
End Sub

このページの上


ブック Workbook

開いているワークブックの名前を表示する
  Dim wb As Workbook

  For Each wb In Workbooks
    Debug.Print wb.Name
  Next wb

このページの上

指定したワークブックをエクセルで開いているか? 
Function ExistsWorkbook(WorkbookName As String) As Boolean
  Dim wb As Workbook

  On Error Resume Next
  Set wb = Application.Workbooks(WorkbookName)
  ExistsWorkbook = Not (wb Is Nothing)
  On Error GoTo 0
End Function

このページの上

ブックを開いたときに実行 Workbook_Open
 ThisWorkbookオブジェクトのWorkbookのOpenイベントを使います。
Private Sub Workbook_Open()
  Application.Wait Now + TimeValue("00:00:01") ' 1秒間待つ
  If IMEStatus = vbIMEModeOff Then SendKeys "{kanji}", True ' [半角/全角]キー *注意 タイミングによっては実行されない場合があります
End Sub

 ブックを閉じるときに実行するには、ThisWorkbookオブジェクトのWorkbookのBeforeCloseイベントを使います。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  If Not ThisWorkbook.Saved Then ThisWorkbook.Save ' ブックを更新した場合は保存します。
End Sub
 Excel 97以前では標準モジュールにAuto_OpenAuto_Closeプロシージャを自作します。
 実行される順番は下記のようになります。
  Workbook_Open
  Auto_Open

  Workbook_BeforeClose
  Auto_Close

このページの上


シート Sheet

アクティブブックのすべてのシートの名前を表示する
  
  Dim sh As Object

  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了

  For Each sh In ActiveWorkbook.Sheets
    Debug.Print sh.Name ' シート名
  Next sh

アクティブブックのすべてのワークシートの名前を表示する
  Dim sh As Object

  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了

  For Each sh In ActiveWorkbook.Worksheets
    Debug.Print sh.Name ' ワークシート名
  Next sh

このページの上

アクティブワークブックに指定したシートがあるか?
Function ExistsSheet(SheetName As String) As Boolean
  Dim sh As Object

  ExistsSheet = False
  If ActiveWorkbook Is Nothing Then Exit Function
  On Error Resume Next
  Set sh = ActiveWorkbook.Sheets(SheetName)
  ExistsSheet = Not (sh Is Nothing)
  On Error GoTo 0
End Function

アクティブワークブックに指定したワークシートがあるか?
Function ExistsWorkSheet(WorkSheetName As String) As Boolean
  Dim sh As Worksheet

  ExistsWorkSheet = False
  If ActiveWorkbook Is Nothing Then Exit Function
  On Error Resume Next
  Set sh = ActiveWorkbook.Worksheets(WorkSheetName)
  ExistsWorkSheet = Not (sh Is Nothing)
  On Error GoTo 0
End Function

このページの上
アクティブワークブックに表示しているシート数を取得する
Function VisibleSheetCount() As Long
  Dim sh As Object

  VisibleSheetCount = 0
  If Workbooks.Count < 1 Then Exit Function
  For Each sh In Sheets
    If sh.Visible = xlSheetVisible Then VisibleSheetCount = VisibleSheetCount + 1
  Next sh
End Function

アクティブブックの表示されているワークシート数を取得する
Function VisibleWorksheetCount() As Long
  Dim sh As Worksheet

  VisibleWorksheetCount = 0
  If Workbooks.Count < 1 Then Exit Function
  For Each sh In Worksheets
    If sh.Visible = xlSheetVisible Then VisibleWorksheetCount = VisibleWorksheetCount + 1
  Next sh
End Function

このページの上


セル


すべてのセルを選択する Cells.Select
 ショートカットキーのCtrl + Aと同じです。
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  Cells.Select

このページの上

アクティブセル領域(空白行と空白列で囲まれたセル範囲)を選択する CurrentRegion
 ショートカットキーのCtrl + Shift + *と同じです。
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  ActiveCell.CurrentRegion.Select

このページの上

指定した条件のセルを選択する SpecialCells
 SpecialCells(Type, Value)・・・特定の種類の定数や数式を含むセルだけを取得します。

 引数Type(XlCellType定数
   xlCellTypeAllFormatConditions・・・表示形式が設定されているセル
   xlCellTypeAllValidation・・・条件の設定が含まれているセル
   xlCellTypeBlanks・・・空の文字列
   xlCellTypeComments・・・コメントが含まれているセル
   xlCellTypeConstants・・・定数が含まれているセル
   xlCellTypeFormulas・・・数式が含まれているセル
   xlCellTypeLastCell・・・使われたセル範囲内の最後のセル
   xlCellTypeSameFormatConditions・・・同じ表示形式が設定されているセル
   xlCellTypeSameValidation・・・同じ条件の設定が含まれているセル
   xlCellTypeVisible・・・すべての可視セル

 引数Value(XlSpecialCellsValue定数
  引数TypeがxlCellTypeConstantsかxlCellTypeFormulasは、引数Valueを指定できます。
  引数Valueに複数の値を加算して指定すると、複数の種類の定数や数式を指定できます。
  引数Valueを省略すると、すべての定数および数式が対象になります。
   xlErrors・・・エラー値
   xlLogical・・・論理値
   xlNumbers・・・数値
   xlTextValues・・・文字
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  On Error Resume Next ' エラーを無視して次の行を実行
  ActiveCell.SpecialCells(xlCellTypeAllFormatConditions).Select  ' 表示形式が設定されているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeAllValidation).Select        ' 条件の設定が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeBlanks).Select               ' 空の文字列のセルを選択する
  ActiveCell.SpecialCells(xlCellTypeComments).Select             ' コメントが含まれているセルを選択する
  ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate    ' 使われたセル範囲の最後のセルを選択する
  ActiveCell.SpecialCells(xlCellTypeSameFormatConditions).Select ' 同じ表示形式が設定されているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeSameValidation).Select       ' 同じ条件の設定が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeVisible).Select              ' すべての可視セルを選択する
  ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select   ' 使用したセルのすべての可視セルを選択する
'
  ActiveCell.SpecialCells(xlCellTypeConstants).Select            ' 定数が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeConstants, xlNumbers).Select ' 定数(数値)が含まれているセルを選択する
  
  ActiveCell.SpecialCells(xlCellTypeFormulas).Select             ' 数式が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeFormulas, xlErrors).Select   ' 数式(エラー値)が含まれているセルを選択する
  On Error GoTo 0

このページの上

使われたセル範囲を選択する UsedRange
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  ActiveSheet.UsedRange.Select

このページの上

指定した列の入力されている最終行に移動する End(xlUp)
'===========================================================
' 指定した列の入力されている最終行に移動する
'===========================================================
Sub GotoLastInputRow(Optional ColumnNumber As Long = 1) ' ColumnNumber:列の番号(A列は1、B列は2...)

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If ColumnNumber < 1 Then Exit Sub

  With Application.Cells(Rows.Count, ColumnNumber)
    If .Value = "" Then
      .End(xlUp).Select ' ショートカットキーの Ctrl + ↑ と同じ
    Else
      .Select
    End If
  End With
End Sub
'===========================================================
' B列の入力されている最終行に移動する
'===========================================================
Sub TestGotoLastInputRow()
  GotoLastInputRow 2  ' B列の入力されている最終行に移動する
End Sub

このページの上

セル範囲の集合(Union)と共有セル範囲(Intersect)
  Dim r1 As Range, r2 As Range  ' セルの選択範囲
  Dim IntersectRange As Range  ' 共有セル範囲
  Dim Msg As String ' メッセージ

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了

  Set r1 = Application.InputBox(Prompt:="複数のセルを選択してください", Title:="セルの選択", Type:=8)
  If TypeName(r1) <> "Range" Then Exit Sub ' [Cancel]ボタンを押した。
  r1.Interior.ColorIndex = 5 ' 青

  Set r2 = Application.InputBox(Prompt:="複数のセルを選択してください", Title:="セルの選択", Type:=8)
  If TypeName(r2) <> "Range" Then Exit Sub ' [Cancel]ボタンを押した。
  r2.Interior.ColorIndex = 6 ' 黄色

  Set IntersectRange = Application.Intersect(r1, r2)
  Msg = "セル範囲の集合:" & Application.Union(r1, r2).Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
  If Not IntersectRange Is Nothing Then
    Msg = Msg & "共有セル範囲:" & IntersectRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    IntersectRange.Interior.ColorIndex = 4 ' 黄緑
    IntersectRange.Select
  End If

  MsgBox Prompt:=Msg, Buttons:=vbOKOnly + vbInformation

このページの上

セルのオフセット(Offset)とセル範囲の変更(Resize)
 下記は アクティブセル領域の1行目を除いたセル範囲を選択します。
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了

  With ActiveCell.CurrentRegion ' アクティブセル領域(空白行と空白列で囲まれたセル範囲)
    If .Rows.Count < 2 Then Exit Sub ' 1行以下は何もしないで終了
    .Offset(RowOffset:=1).Resize(Rowsize:=.Rows.Count - 1).Select ' 2行目以降のセルを選択する
  End With

このページの上

選択しているのはセルか? Selection
 StrComp(TypeName(Selection), "Range") = 0で判断します。
 下記は上下あるいは左右に隣接する選択セルを交換します。
  Dim SaveActiveSheet As Worksheet ' アクティブシートを保存
  Dim TempWorksheet As Worksheet ' 一時シート

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  If (Selection.Areas.Count <> 1) Or (Selection.Count = 1) Then
    MsgBox "セル範囲が正しくありません!", vbOKCancel + vbExclamation
    Exit Sub
  End If

  If (Selection.Columns.Count <> 2) And (Selection.Rows.Count <> 2) Then
    MsgBox "2列あるいは2行のセル範囲を選択してください!", vbOKCancel + vbExclamation
    Exit Sub
  End If

  Set SaveActiveSheet = ActiveSheet ' アクティブシートの保存
  Set TempWorksheet = Worksheets.Add 'ワークシートの追加
  SaveActiveSheet.Activate ' 元のアクティブシートを選択
  Selection.Copy Destination:=TempWorksheet.Range("A1") ' 選択セル範囲の保存
  If Selection.Columns.Count = 2 Then ' 2列の場合
    Selection.Columns(2).Copy Destination:=Selection.Columns(1) ' 2列目を1列目にコピー
    TempWorksheet.Range("A1").CurrentRegion.Columns(1).Copy Destination:=Selection.Columns(2) ' 保存した1列目を2列目にコピー
  Else ' 2行の場合
    Selection.Rows(2).Copy Destination:=Selection.Rows(1) ' 2行目を1行目にコピー
    TempWorksheet.Range("A1").CurrentRegion.Rows(1).Copy Destination:=Selection.Rows(2) ' 保存した1行目を2行目にコピー
  End If

  Application.DisplayAlerts = False ' 警告やメッセージを表示しない
  TempWorksheet.Delete ' 一時シートの削除
  Application.DisplayAlerts = True ' 警告やメッセージを表示する

このページの上

隣接しない複数の選択範囲 Areas
 下記は隣接しない複数の選択範囲のアドレスをイミディエイトウィンドウに表示します。
  Dim i As Long

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  Debug.Print "Areas.Count:" & Selection.Areas.Count
  For i = 1 To Selection.Areas.Count
    Debug.Print
    With Selection.Areas(i)
      Debug.Print "Areas(" & CStr(i) & ").Count:" & .Count
      Debug.Print "Areas(" & CStr(i) & ").Address=" & .Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Left  Top    Address:" & .Cells(1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Right Top    Address:" & .Cells(1, .Columns.Count).Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Left  Bottom Address:" & .Cells(.Rows.Count, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Right Bottom Address:" & .Cells(.Count).Address(RowAbsolute:=False, ColumnAbsolute:=False)
    End With
  Next i

  Application.VBE.Windows("イミディエイト").Visible = True ' イミディエイトウィンドウを表示します。

 下記は2つの隣接しない選択セル範囲を交換します。
  Dim SaveActiveSheet As Worksheet ' アクティブシートを保存
  Dim TempWorksheet As Worksheet ' 一時シート

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  If Selection.Areas.Count <> 2 Then
    MsgBox "2つの隣接しないセル範囲を選択してください!", vbOKCancel + vbExclamation
    Exit Sub
  End If
  If (Selection.Areas(1).Columns.Count <> Selection.Areas(2).Columns.Count) Or (Selection.Areas(1).Rows.Count <> Selection.Areas(2).Rows.Count) Then
    MsgBox "同じサイズのセル範囲を選択してください!", vbOKCancel + vbExclamation
    Exit Sub
  End If

  Set SaveActiveSheet = ActiveSheet ' アクティブシートの保存
  Set TempWorksheet = Worksheets.Add 'ワークシートの追加
  SaveActiveSheet.Activate ' 元のアクティブシートを選択

  Selection.Areas(1).Copy Destination:=TempWorksheet.Range("A1")
  Selection.Areas(2).Copy Destination:=Selection.Areas(1)
  TempWorksheet.Range("A1").CurrentRegion.Copy Destination:=Selection.Areas(2)

  Application.DisplayAlerts = False ' 警告やメッセージを表示しない
  TempWorksheet.Delete ' 一時シートの削除
  Application.DisplayAlerts = True ' 警告やメッセージを表示する

このページの上

セルを含む列を取得 EntireColumn
 下記は選択したセルの列を選択します。
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  Selection.EntireColumn.Select

 下記は選択したセルの行を選択します。
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  Selection.EntireRow.Select

このページの上


その他

イミディエイトウィンドウに出力 Debug.Print
  Debug.Print "StartupPath:" & Application.StartupPath ' Excelの起動フォルダの絶対パス(末尾の円記号 (\) は含まない)
  Debug.Print "DefaultFilePath:" & Application.DefaultFilePath ' ファイルを開くときに既定のカレントフォルダ名
  Debug.Print "TemplatesPath:" & Application.TemplatesPath 'テンプレートが保存されているローカルパス
  Debug.Print "UserLibraryPath:" & Application.UserLibraryPath ' COM アドインがインストールされているパス

【参考】Visual Basic Editorのイミディエイトウィンドウを表示するショートカットキーはCtrl + Gです。
このページの上

Format関数で数字の先頭に0を付ける
  Debug.Print Format("123", "00000") ' 先頭に0を付ける(数字のみ)00123
  Debug.Print "[" & Format("ABC", "@@@@@") & "]"  ' 半角のスペースを埋めて右寄せ  [  ABC]
  Debug.Print "[" & Format("ABC", "!@@@@@") & "]" ' 半角のスペースを埋めて左寄せ  [ABC  ]

このページの上

変数の宣言を強制 Option Explicit
 変数名の入力ミスをなくすために、Option Explicitを使いましょう。
Option Explicit

「Visual Basic Editor」の[ツール]の[オプション]メニューを実行し、[編集]タブの[変数の宣言を強制する]ボタンにチェックを入れましょう。
チェックすると自動でOption Explicitが追加されます。
VBEのオプション

このページの上

キーコードを転送 SendKeys
 SendKeys キーの文字列, Wait
 キーの文字列の英字は小文字を使います。
 Shiftは + (正符号)
 Ctrlは ^ (カレット)
 Altは % (パーセント記号)
 {HOME}、{END}、{LEFT}、{RIGHT}、{UP}、{DOWN}、{INSERT}、{DELETE} 、{RETURN}、{F1} 〜 {F15}など詳細はヘルプを参照してください。
 WaitがTrueは、送られたキーが処理されてからマクロに制御が戻ります。
  SendKeys "^o", Wait:=True ' Ctrl + O ファイルを開く
 エクセルのバージョンによりできない場合もあります。

このページの上

文字列の変換(小文字、大文字、先頭のみ大文字、半角、全角、カタカナ、ユニコード) StrConv
  Debug.Print "小文字 " & StrConv("abcDEF", vbLowerCase)
  Debug.Print "大文字 " & StrConv("abcDEF", vbUpperCase)
  Debug.Print "先頭のみ大文字 " & StrConv("abcDEF", vbProperCase)
  Debug.Print "半角 " & StrConv("アイウエお", vbNarrow)
  Debug.Print "全角 " & StrConv("アイウエお", vbWide) ' 【注意】変換できない「゙゚」は半角の?になります。(鼻促音の「カ゚」は「カ?」)
  Debug.Print "カタカナ " & StrConv("アイウエお", vbKatakana)
  Debug.Print "ひらがな " & StrConv("アイウエお", vbHiragana)
  Debug.Print "バイト数(Unicode): " & LenB(StrConv("アイウエお", vbUnicode)) ' ユニコードでは半角の文字でも、1文字は2バイトになります
  Debug.Print "バイト数(Shift JIS): " & LenB(StrConv("アイウエお", vbFromUnicode))

このページの上

ブックのドキュメントプロパティの取得 BuiltinDocumentProperties
' ブックのドキュメントプロパティの取得し、新規作成したシートに書き込む。
  Dim RowCnt As Long ' セルの行番号
  Dim dp As DocumentProperty ' ドキュメント プロパティ

  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了
  On Error Resume Next
  RowCnt = 1
  With Worksheets.Add
    .Name = "BuiltinDocumentProperties"
    For Each dp In ActiveWorkbook.BuiltinDocumentProperties
      Cells(RowCnt, 1).Value = dp.Name
      Cells(RowCnt, 2).Value = dp.Value
      RowCnt = RowCnt + 1
    Next dp
    Columns("A:B").AutoFit ' セルの列幅を内容に合わせて調整する
    Range("A1").Activate
  End With
  On Error GoTo 0

このページの上

プログラムを実行 Shell
 下記はWindowsのメモ帳 (Notepad.exe)を起動します。
  Dim ProgID

  ProgID = Shell("Notepad.exe", vbNormalFocus) ' メモ帳を起動
  If ProgID = 0 Then Exit Sub ' 問題発生したので終了
  Application.Wait Now + TimeValue("00:00:01") ' 1秒間待つ
  AppActivate ProgID ' メモ帳をアクティブにする
  SendKeys ".LOG{ENTER}" '
  ' 先頭行が「.LOG」のファイルを次回からメモ帳で開くと、日付と時間が自動で挿入されます。

このページの上

エクセルファイルの一覧を表示する Dir
  Dim PathName As String ' 検索するパス名(C:\Users\≪ユーザ名≫\Documents\*.xl* ≪ユーザ名≫はログオンしたユーザ名により異なる)
  Dim FileName As String ' 取得するファイル名

  PathName = Application.DefaultFilePath & Application.PathSeparator & "*.xl*"
  FileName = Dir(PathName, vbArchive + vbReadOnly + vbSystem + vbHidden)
  Do While FileName <> ""
    Debug.Print FileName
    FileName = Dir()
  Loop

このページの上

エラー処理 On Error
 下記はエラーが発生しても中断せず、次のステートメントから実行します。
  On Error Resume Next ' エラーでも中断せず、次のステートメントから実行
  Worksheets.Add.Name = "Sample" ' 既に同じシート名が存在していても、エラーにはならない。
  On Error GoTo 0 ' エラーの場合は実行時エラーを発生する

 下記はBの数字が0の場合にエラーになります。(0 で除算しました)
  Dim Ret As VbMsgBoxResult ' MsgBoxの返値
  Dim Msg As String ' メッセージ
  Dim Num As Variant ' 入力の値
  Dim a As Double, B As Double ' 入力の数字
  Dim Ans As Double ' 答え

  On Error Resume Next ' エラーでも中断せず、次のステートメントから実行
  Worksheets.Add.Name = "Sample" ' 既に同じシート名が存在していても、エラーにはならない。
  On Error GoTo 0 ' エラーの場合は実行時エラーを発生する

  On Error GoTo Error_Handle ' エラーが発生したら、「Error_Handle」ラベルに移動する
  Num = Application.InputBox(Prompt:="A / BのAの数字を入力してください。", Title:="数字の入力", Type:=1)
  If VarType(Num) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押したので終了
  a = Num

  Num = Application.InputBox(Prompt:="A / BのBの数字を入力してください。", Title:="数字の入力", Type:=1)
  If VarType(Num) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押したので終了
  B = Num

  Ans = a / B ' ● Bの値が0の場合にエラーが発生する
  MsgBox Prompt:=a & " / " & B & " = " & Ans, Title:="答え"
  Exit Sub

Error_Handle: ' エラー処理
  Msg = "エラー番号:" & Err.Number & vbCrLf & Err.Description
  Err.Clear ' エラーをクリアー
  Ret = MsgBox(Msg, vbExclamation + vbAbortRetryIgnore)
  Select Case Ret
    Case vbAbort ' 中止
      Exit Sub
    Case vbRetry ' 再試行
      Resume ' 同じ行のステートメントを実行 *注意 この例では再度エラーになる、Bの値を再入力する必要があります。
    Case vbIgnore '無視
      Resume Next ' 次の行のステートメントから実行
  End Select

このページの上

プロシージャの引数の省略 Optional IsMissing
 Optionalを指定した引数は省略可能です。
 IsMissing関数は省略可能なバリアント型 (Variant) の引数を省略した場合はTrueを返します。
 下記は月末日を取得する関数のサンプルです。
' 月末日()・・・今月の月末日を取得する
' 月末日(年月日 as Date)・・・指定した年月日の月末日を取得する
' 月末日(年,月 as Integer)・・・指定した年と月の月末日を取得する
Function 月末日(Optional Arg1, Optional Arg2) As Date
  Dim Today As Date ' 今日

  If IsMissing(Arg1) Then ' 月末日()
    Today = Now()
    月末日 = DateSerial(year(Today), Month(Today) + 1, 1) - 1
  ElseIf IsMissing(Arg2) Then ' 月末日(年月日)
    月末日 = DateSerial(year(Arg1), Month(Arg1) + 1, 1) - 1
  Else ' 月末日(年,月)
    月末日 = DateSerial(Arg1, Arg2 + 1, 1) - 1
  End If
End Function
'-----------------------------------------------------------
Sub test月末日()
  Dim Today As Date ' 今日
  Dim InputDate As Variant ' 入力した日付

  Today = Now()
  Debug.Print "先月の月末日は" & 月末日(year(Today), Month(Today) - 1)
  Debug.Print "今月の月末日は" & 月末日()
  Debug.Print "来月の月末日は" & 月末日(year(Today), Month(Today) + 1)

  InputDate = Application.InputBox(Prompt:="日付の入力(yyy/mm/dd):", Title:="月末日の取得", Default:=Format(Today, "yyyy/mm/dd"), Type:=2)
  If VarType(InputDate) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押したら、終了。
  If Not IsDate(InputDate) Then Exit Sub ' 日付でなければ終了。
  Debug.Print Format(InputDate, "yyyy/mm/dd") & "の月末日は" & 月末日(year(DateValue(InputDate)), Month(DateValue(InputDate)))
End Sub

このページの上

すべてのオブジェクトを削除 Shapes.SelectAll Selection.Delete

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If MsgBox(Prompt:="すべてのオブジェクトを削除しますか?", Buttons:=vbYesNo + vbQuestion) = vbNo Then Exit Sub
  ActiveSheet.Shapes.SelectAll ' すべてのオブジェクトを選択
  Selection.Delete ' 選択したオブジェクトを削除

このページの上


すべてのブックで使える[個人用マクロ ブック]  Personal.xlsb

 1.[開発] タブの [コード] で、[マクロの記録] をクリックします。
マクロ保存先
 2.[マクロの保存先] ボックスの一覧で、[個人用マクロ ブック] を選択してから[OK]ボタンをクリックします。
 隠し個人用マクロ ブック (Personal.xlsb) が作成されます。

 Personal.xlsbが作成されるのフォルダの場所は環境により異なります。
 Windows Vistaの場所
C:\Users\≪ユーザー名≫\AppData\Local\Microsoft\Excel\XLStart

 Windows XPの場所
C:\Documents and Settings\≪ユーザー名≫\Application Data\Microsoft\Excel\XLStart

≪ユーザー名≫はログオンしたユーザ名です。
 XLStartフォルダのファイルは、Excelの起動時に自動で開きます。

 *注 Excel 2003まではPersonal.xlsです。

このページの上

メニューの追加 Application.CommandBars
 Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True)でワークシートメニューに追加します。
 Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Temporary:=True)でセルのショートカットメニューに追加します。
 セルの列見出しのショートカットメニューは"Column";、行見出しは"Row"、シートタブは"Ply"です。
 Caption・・・表示されるメニューの文字列 アクセスキーは半角の英数字の前に半角のアンパーサンド(&
 OnAction・・・実行するマクロ名
 Enabled・・・使用可・不可
 Visible・・・表示・非表示
 BeginGroup・・・上に区切り線を表示する・しない
 State・・・チェックする・しない
 ShortcutText・・・ショートカットキーの文字列
 Delete・・・メニューの削除
 Reset・・・メニューのリセット
'=============================================================================
' メニューの処理
'=============================================================================
Const csVersion As String = "Version 1.0.0"
Const MainMenu As String = "Test Menu(&T)" ' メニューのキャプション
Const DisplayStatusBarMenu As String = "ステータスバーの表示・非表示(&S)"
Const ColumnWidthAutofitMenu As String = "選択したすべてのセルの列の幅を内容に合わせる変更(&C)"
Const RowHeightAutofitMenu As String = "選択したすべてのセルの行の高さを内容に合わせる変更(&R)"
'===========================================================
' 今日の日付と今の時間の表示
'===========================================================
Sub OnNowClick()
  MsgBox Prompt:=Now(), Buttons:=vbInformation, Title:="今日の日付と今の時間"
End Sub
'===========================================================
' 選択したすべてのセルの列の幅を内容に合わせて変更
'===========================================================
' *注 選択したのは列でなく、セルです。
Sub OnColumnWidthAutofitClick()
  ActiveWindow.RangeSelection.EntireColumn.AutoFit
End Sub
'===========================================================
' 選択したすべてのセルの行の高さを内容に合わせて変更
'===========================================================
' *注 選択したのは行でなく、セルです。
Sub OnRowHeightAutofitClick()
  ActiveWindow.RangeSelection.EntireRow.AutoFit
End Sub
'===========================================================
' ステータスバーの表示・非表示
'===========================================================
Sub OnDisplayStatusBarClick()
  Application.DisplayStatusBar = Not Application.DisplayStatusBar
End Sub
'===========================================================
' バージョン情報
'===========================================================
Sub OnAboutClick()
  Dim Msg As String

  Msg = ThisWorkbook.Name & vbCrLf & vbCrLf & csVersion
  MsgBox Prompt:=Msg, Buttons:=vbInformation, Title:="バージョン情報"
End Sub
'===========================================================
' Test Menuメニューのクリック
'===========================================================
Sub OnMainMenuClick()
  With Application.CommandBars("Worksheet Menu Bar").Controls(MainMenu)
    ' メニューのチェック
    .Controls(DisplayStatusBarMenu).State = Application.DisplayStatusBar

    ' メニューの使用可・不可 --- セルがないダイアログシートを選択した場合は使用禁止にする。
    .Controls(ColumnWidthAutofitMenu).Enabled = Not (Application.ActiveCell Is Nothing)
  End With
End Sub
'=============================================================================
' メニューの削除
'=============================================================================
Sub DelMenu()
  On Error Resume Next ' メニューがないのに削除するとエラーになるため、エラー無視
  Application.CommandBars("Worksheet Menu Bar").Controls(MainMenu).Delete
  Application.CommandBars("Cell").Controls(MainMenu).Delete
  On Error GoTo 0
End Sub
'=============================================================================
' メニューの追加
'=============================================================================
Sub SetMenu(pMenu As String)
  With Application.CommandBars(pMenu).Controls.Add(Type:=msoControlPopup, Temporary:=True) ' Temporary:=True で終了時に削除
    .Caption = MainMenu

    With .Controls.Add
      .Caption = ColumnWidthAutofitMenu
      .OnAction = "OnColumnWidthAutofitClick"
    End With
    With .Controls.Add
      .Caption = RowHeightAutofitMenu
      .OnAction = "OnRowHeightAutofitClick"
    End With

    If StrComp(pMenu, "Worksheet Menu Bar") = 0 Then ' ワークシートのメニューのみに追加
      .OnAction = "OnMainMenuClick"
      With .Controls.Add
        .Caption = "今日の日付と今の時間(&N)..."
        .OnAction = "OnNowClick"
        .BeginGroup = True
        .ShortcutText = "Ctrl+M"
      End With
      With .Controls.Add
        .Caption = DisplayStatusBarMenu
        .OnAction = "OnDisplayStatusBarClick"
        .BeginGroup = True
      End With
      With .Controls.Add
        .Caption = "バージョン情報(&A)..."
        .OnAction = "OnAboutClick"
      End With
    End If
  End With
End Sub
'-----------------------------------------------------------
Sub AddMenu()
  DelMenu ' メニューの削除
  SetMenu ("Worksheet Menu Bar") ' ワークシートのメニュー
  SetMenu ("Cell") ' セルのショートカットメニュー
End Sub
'===========================================================
' 初期処理
'===========================================================
Sub Auto_Open()
  Application.OnKey "^m", "OnNowClick" ' ショートカットキーの登録 [Ctrl]+[M]
  AddMenu ' メニューの追加
End Sub
'===========================================================
' 終了処理
'===========================================================
Sub Auto_Close()
  Application.OnKey "^m" ' ショートカットキーの取り消し
  DelMenu ' メニューの削除
End Sub
'===========================================================
' メニューのリセット
'===========================================================
Sub ResetMenu()
  Application.CommandBars("Worksheet Menu Bar").Reset ' ワークシートのメニュー
  Application.CommandBars("Cell").Reset ' セルのショートカットメニュー
End Sub

このページの上

すべてのメニューバーとツールバーをリセットする(使用者が作成した場合は削除) Application.CommandBars
 BuiltInで組み込みのコマンドバーであればResetし、追加した場合はDeleteします。
Sub ResetCommandBars()
  Dim cbar As CommandBar

  On Error Resume Next
  For Each cbar In CommandBars
    If CommandBars(cbar.Name).BuiltIn Then
      CommandBars(cbar.Name).Reset
    Else
      CommandBars(cbar.Name).Delete
    End If
  Next
  On Error GoTo 0
End Sub

このページの上