間違い探し

Sub File_Open()
  ' フルパス名ではありませんが、カレントディレクトリにファイル「Sample001.xls」があるものとします。
  If Dir("Sample001.xls") = "" Then
    MsgBox "ファイルが見つかりません!", vbCritical
    Exit Sub
  End If
  
  With Workbooks.Open("Sample00l.xls")
    With Worksheets.Add
      Range("A1").Value = Date
      Range("A1").NumberFormatLocal = "yyyy年mm月dd日"
      
      Range("A2").Value = Time
      Range("A2").NumberFormatLocal = "h時mm分ss秒"
      
      Range("A1").Select
    End With
  End With
End Sub

Sub AllSelectSheets()
  Dim sh As Worksheet
   
  For Each sh In Worksheets
    sh.Select False
  Next
End Sub

Sub LogAndRound()
  Dim f As Double
  
  f = 2.5
  Debug.Print Log(f) & " --> Log(" & f & ")"
  Debug.Print Application.WorksheetFunction.Log(f) & " --> Application.WorksheetFunction.Log(" & f & ")"
  
  Debug.Print ""
  Debug.Print Round(f) & " --> Round(" & f & ")" ' ●　答えは？
  Debug.Print Application.WorksheetFunction.Round(f, 0) & " --> Application.WorksheetFunction.Round(" & f & ", 0)"
   
  Debug.Print ""
  Debug.Print "f     Round  Application.WorksheetFunction.Round(f, 0)"
  Debug.Print Application.WorksheetFunction.Rept("-", 54)
  
  f = 2.1
  Do Until f = 2.6
    Debug.Print f & "     " & Round(f) & "      " & Application.WorksheetFunction.Round(f, 0)
    f = f + 0.1
    If f > 3 Then Exit Do
  Loop
  ' ＊参考 Visual Basic Editorのイミディエイト ウィンドウを表示するショートカットキーは Ctrl + G です。
End Sub

Sub Hello()
  Dim Name As String
  
  Name = Application.InputBox(Prompt:="名前：", Title:="名前の入力", Default:="名なしの権兵衛", Type:=2) ' Type:=2は文字列 (テキスト)
  If VarType(Name) = vbBoolean Then Exit Sub      ' [Cancel]ボタンを押した
  If Name = "" Then Name = "名なしの権兵衛"
  MsgBox Prompt:="こんにちは " & Name & " さん！", Buttons:=vbInformation, Title:="挨拶"
End Sub

Option Private Module ' プロジェクトの外部からモジュールの内容を参照できません。
Option Base 1 ' 配列の添字の最小値の既定値を1に設定します。
Option Compare Text ' 文字列データの既定の比較方法をTextモードに設定します。
'===========================================================
' 入力した数字の合計を求める
'===========================================================
Sub SumSumple()
  ' 数字の入力
  ReDim Suuji(3) As Double
  n = 1
  Do Until n > 3
    a = Application.InputBox(Prompt:="数字(" & CStr(n) & ")：", Title:="数字の入力", Type:=1)
    If VarType(a) = vbBoolean Then Exit Do ' [Cancel]ボタンは入力を中止
    Suuji(n) = a
    n = n + 1
  Loop
  If n < 2 Then Exit Sub ' 何も入力しない場合は終了
  
  ' 数字の合計
  ReDim Preserve Suuji(n - 1) ' 配列の再割り当て
  Goukei = 0
  For n = LBound(Suuji) To UBound(Suuji)
    Goukei = Goukei + Suuji(n)
  Next n
  
  ' 合計の表示
  Msg = "合計は " & CStr(Gokei) & " です。"
  MsgBox Prompt:=Msg, Buttons:=vbInformation, Title:="合計"
End Sub

'===========================================================
' 初期処理
'===========================================================
Sub Auto_Open()
  Application.OnKey "^{M}", "CtrlM" ' ショートカットキーの登録
End Sub
'===========================================================
' 終了処理
'===========================================================
Sub Auto_Close()
  Application.OnKey "^M" ' ショートカットキーの取り消し
End Sub
'===========================================================
' Ctrl + M キーの処理
'===========================================================
Sub CtrlM()
  If MsgBox(prompt:="メニューをリセットしますか？", Buttons:=vbQuestion + vbYesNo, Title:="メニューのリセット") <> vbYes Then Exit Sub
  
  Application.CommandBars("Worksheet Menu Bar").Reset ' ワークシートメニューのリセット
  Application.CommandBars("Cell").Reset               ' セルの右クリックメニューのリセット
  Application.CommandBars("Column").Reset             ' 列見出しの右クリックメニューのリセット
  Application.CommandBars("Row").Reset                ' 行見出しの右クリックメニューのリセット
  Application.CommandBars("Ply").Reset                ' シートタブの右クリックメニューのリセット
End Sub

Sub LongTimeProc()
  Dim Cnt As Long ' カウンタ
  Dim tmpCalculation As XlCalculation ' 計算方法のモード
  Dim IsDisplayStatusBar As Boolean ' ステータスバーの表示状態を保存
  Dim WaitTime As Variant ' 待ち時間
  
  Application.EnableEvents = False ' イベントを無効にします。
  tmpCalculation = Application.Calculation ' 計算方法のモードを保存
  Application.Calculation = xlCalculationManual ' 計算方法のモードを手動にし、計算しない
  Application.StatusBar = "実行中です。しばらくお待ちください．．．" ' ステータスバーにメッセージを表示
  IsDisplayStatusBar = Application.DisplayStatusBar ' ステータスバーの表示状態を保存
  Application.DisplayStatusBar = True ' ステータスバーを表示
  Application.Cursor = xlWait ' マウスカーソルを砂時計
  Application.ScreenUpdating = False '画面の更新を停止して、ちらつきを防止（ステータスバーのメッセージは更新できます）
  
  ' 長い処理を開始 --->
  For Cnt = 1 To 10
    WaitTime = Now() + TimeValue("00:00:01")
    While (Now() < WaitTime)
      DoEvents ' オペレーティング システムによって処理できるようにする。
    Wend
    Application.StatusBar = "実行中です。しばらくお待ちください．．．" & String(Cnt, "■") & String(10 - Cnt, "□") ' ステータスバーにメッセージを表示
  Next Cnt
  ' 長い処理を終了 <---
  
  Application.EnableEvents = True ' イベントを有効にします。
  Application.Calculation = tmpCalculation ' 計算方法のモードを元に戻す
  Application.StatusBar = "" ' ステータスバーをを元に戻す
  Application.DisplayStatusBar = IsDisplayStatusBar ' ステータスバーの表示を元に戻す
  Application.Cursor = xlDefault ' マウスカーソルを省略値に戻す
  Application.ScreenUpdating = True '画面の更新をする
End Sub

Sub LastRow()
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  Application.Cells(65536, ActiveCell.Column).End(xlUp).Select
End Sub

Sub Upper()
  Dim r As Range
  
  For Each r In Selection
    r.Value = StrConv(r.Value, vbUpperCase)
  Next r
End Sub

Sub DelNoUseWorkSheet()
  Dim sh As Worksheet
    
  Application.DisplayAlerts = False ' 削除の確認メッセージを表示しない
  For Each sh In Worksheets
    If Application.WorksheetFunction.CountA(sh.UsedRange) = 0 Then ' すべてのセルが空白
      sh.Delete
    End If
  Next sh
  Application.DisplayAlerts = True ' 警告やメッセージを表示します。
End Sub

Option Explicit ' すべての変数に対して、明示的な宣言を強制する
Option Compare Text ' テキストモードで文字列を比較する

'===========================================================
' アクティブワークブックに指定したワークシートがあるか？
'===========================================================
Function ExistsWorkSheet(WorkSheetName As String) As Boolean
  Dim sh As Object
  
  ExistsWorkSheet = False
  For Each sh In ActiveWorkbook.Worksheets ' ●注意　シートでなく、ワークシートのみ（グラフとダイアログは除く）
    If LCase(sh.Name) = LCase(WorkSheetName) Then
      ExistsWorkSheet = True
      Exit Function
    End If
  Next sh
End Function
'===========================================================
' アクティブワークブックに指定したシートがあるか？
'===========================================================
Function ExistsSheet(SheetName As String) As Boolean
  Dim sh As Object
  
  On Error Resume Next
  Set sh = ActiveWorkbook.Sheets(SheetName) ' ● すべてのシート
  On Error GoTo 0
  
  ExistsSheet = Not (sh Is Nothing)
  Set sh = Nothing
End Function
'===========================================================
' 指定したワークブックをエクセルで開いているか？
'===========================================================
Function ExistsWorkbook(WorkbookName As String) As Boolean
  Dim wb As Workbook
  
  ExistsWorkbook = False
  For Each wb In Workbooks
    If StrComp(wb.Name, WorkbookName, vbTextCompare) = 0 Then
      ExistsWorkbook = True
      Exit Function
    End If
  Next wb
End Function
'===========================================================
' 最近使用したファイルのリストを作成する
'===========================================================
Sub RecentFilesSheet()
  Const csWorkbookName = "Book1.xls"
  Const csWorkSheetName = "[RecentFiles]"
  Dim ARow As Long
  
  If ExistsWorkbook(csWorkbookName) Then
    Workbooks(csWorkbookName).Activate
  Else
    Workbooks.Add
  End If
  
  If ExistsSheet(csWorkSheetName) Then
    If Sheets(csWorkSheetName).Visible <> xlSheetVisible Then Sheets(csWorkSheetName).Visible = xlSheetVisible
    Sheets(csWorkSheetName).Activate
    Beep
    MsgBox "既にシート " & csWorkSheetName & " は存在してます。" & vbCrLf & "シートを削除してからもう一度実行してください。", vbExclamation
  Else
    With Worksheets.Add
      .Name = csWorkSheetName
      For ARow = 1 To Application.RecentFiles.Maximum
        Application.Cells(ARow, 1).Value = Application.RecentFiles(ARow).Path ' 最近使用したファイルのリストのパス名
      Next ARow
      Application.Columns(1).AutoFit ' 列の幅を内容に合わせて調節する
    End With
  End If
  
  If ExistsWorkSheet(csWorkSheetName) Then Application.Range("A1").Select
End Sub

Sub PrintSelectCell()
  If ActiveWorkbook Is Nothing Then Exit Sub ' ブックを開いてなければ何もしないで終了
  If TypeName(ActiveSheet) <> "WorkSheet" Then Exit Sub ' アクティブシートがワークシート（マクロシート）でなければ何もしないで終了
  If StrComp(TypeName(ActiveWindow.Selection), "Range", vbTextCompare) <> 0 Then Exit Sub ' 選択しているのがセルでなければ何もしないで終了
  Debug.Print "ワークブック名：" & ActiveWorkbook.Name
  Debug.Print "ワークシート名：" & ActiveSheet.Name
  Debug.Print "選択しているセルのアドレス：" & ActiveWindow.Selection.Address
  Debug.Print "選択しているセルの数：" & ActiveWindow.Selection.Count
  ' ＊参考 Visual Basic Editorのイミディエイト ウィンドウを表示するショートカットキーは Ctrl + G です。
End Sub

Sub DivSample()
  Dim n As Variant   ' 入力用の数字
  Dim a, b As Double ' 計算用の数字
  Dim Msg As String  ' メッセージ
  
  n = Application.InputBox(prompt:="数字を入力してください。a", Title:="a / b", Type:=1)
  If VarType(n) = vbBoolean Then Exit Sub ' [Cancel]キーを押した。
  a = n
  n = Application.InputBox(prompt:="数字を入力してください。b", Title:="a / b", Type:=1)
  If VarType(n) = vbBoolean Then Exit Sub ' [Cancel]キーを押した。
  b = n
  
  Msg = "割り算 a  /  b = " & a / b & Chr(13) & Chr(10) _
       & "商 　　a  \  b = " & a \ b & Chr(13) & Chr(10) & "余り 　a Mod b = " & a Mod b
  MsgBox prompt:=Msg, Buttons:=vbInformation, Title:="計算結果"
End Sub

Public Function IsLeapYear(Optional pYear As Long) As Boolean
  Dim Today As Date ' 今日
  Dim wYear As Long ' 年
  
  Application.Volatile ' いずれかのセルで計算が行われるたびに再計算を行う
  
  If IsMissing(pYear) Then ' 引数の年を省略した場合は今年とする
    Today = Now() ' 今
    wYear = Year(Today) ' 今年
  Else
    wYear = pYear
  End If
  
  IsLeapYear = ((wYear Mod 400) = 0) Or (((wYear Mod 100) <> 0) And ((wYear Mod 4) = 0)) ' 閏年なら True
End Function

Sub DeleteHyperlinks()
  Dim i As Long
  
  If Application.ActiveCell Is Nothing Then Exit Sub ' アクティブシートにセルがなければ終了
  If Application.ActiveSheet.Hyperlinks.Count < 1 Then Exit Sub ' ハイパーリンクがなければ終了
  If MsgBox(prompt:="アクティブシートのすべてのハイパーリンクを削除しますか？", Buttons:=vbYesNo + vbQuestion) = vbNo Then Exit Sub
  For i = 1 To Application.ActiveSheet.Hyperlinks.Count
    Application.ActiveSheet.Hyperlinks(i).Delete
  Next i
End Sub