HOME > エクセルVBA > 間違い探し

間違い探し


【ダウンロード】Miss.zip
【動作環境】Windows Vista Excel 2010 (97-2003形式で保存)
【作成日】2009年03月08日
【更新日】2016年11月05日

前提条件
 OSはWindows Vistaで、Excelのバージョンは2007です。
 ワークブックやシートの保護はなしで、書き込み可能とします。
 複数の間違いがある場合もあります。

問題1 ファイルを開く

問題2 すべてのシートを選択

問題3 Log関数とRound関数

問題4 挨拶のメッセージを表示する

問題5 入力した数字の合計を求める

問題6 ショートカットキーのマクロ

問題7 長い時間がかかる処理

問題8 アクティブセルの列の最終行に移動

問題9 選択したセルの英字の小文字を大文字にする

問題10 アクティブブックの空白のワークシートを削除する

問題11 最近使用したファイルのリストを作成する

問題12 選択しているセルのアドレスを表示

問題13 割り算、商、余りを求める

問題14 指定した年が閏年か判定する

問題15 すべてのハイパーリンクを削除する


問題1 ファイルを開く

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
ヒント! エクスプローラからファイルSample001.xlsを開けても、ファイルが見つからない実行時エラー'1004'になる事があります。
答え

このページの上

問題2 すべてのシートを選択

Sub AllSelectSheets()
  Dim sh As Worksheet

  For Each sh In Worksheets
    sh.Select False
  Next
End Sub
ヒント! ワークシートがあっても、エラーになる場合があります。
答え

このページの上

問題3 Log関数とRound関数

注意 これは間違い探しではありません。結果を予想してください。
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
ヒント! Round(2.5)はいくつだろうか?
答え

このページの上

問題4 挨拶のメッセージを表示する

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
ヒント! [Cancel]ボタンを押しても、処理が続く場合があります。
答え

このページの上

問題5 入力した数字の合計を求める

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
ヒント! 最後に合計は何と表示されるだろうか?
答え

このページの上

問題6 ショートカットキーのマクロ

'===========================================================
' 初期処理
'===========================================================
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
ヒント! ショートカットキー
答え

このページの上

問題7 長い時間がかかる処理

Option Explicit
'===========================================================
' 長い時間がかかる処理
'===========================================================
Sub LongTimeProc()
  Dim Cnt As Long ' カウンタ
  Dim tmpCalculation As XlCalculation ' 計算方法のモード
  Dim IsDisplayStatusBar As Boolean ' ステータスバーの表示状態を保存
  Dim WaitTime As Variant ' 待ち時間
  Dim IsDisplayPageBreaks As Boolean  ' 改ページの有効・無効

  Application.EnableEvents = False ' イベントを無効にします。
  tmpCalculation = Application.Calculation ' 計算方法のモードを保存
  If Not Application.ActiveCell Is Nothing Then
    tmpCalculation = Application.Calculation ' 計算方法のモードを保存
    Application.Calculation = xlCalculationManual ' 計算方法のモードを手動にし、計算しない
  End If
  If Not ActiveSheet Is Nothing Then
    IsDisplayPageBreaks = ActiveSheet.DisplayPageBreaks ' 改ページの有効・無効を保存します。
    ActiveSheet.DisplayPageBreaks = False ' 改ページを無効にします。
  End If
  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 ' イベントを有効にします。
  If Not Application.ActiveCell Is Nothing Then
    Application.Calculation = tmpCalculation ' 計算方法のモードを元に戻す
  End If
  If Not ActiveSheet Is Nothing Then ActiveSheet.DisplayPageBreaks = IsDisplayPageBreaks ' 改ページを元に戻します。
  Application.StatusBar = "" ' ステータスバーをを元に戻す
  Application.DisplayStatusBar = IsDisplayStatusBar ' ステータスバーの表示を元に戻す
  Application.Cursor = xlDefault ' マウスカーソルを省略値に戻す
  Application.ScreenUpdating = True '画面の更新をする
End Sub
ヒント1 ScreenUpdatingFalseでも、StatusBarの文字列は更新され表示されます。
ヒント2 処理を途中で終了した場合は?
答え

このページの上

問題8 アクティブセルの列の最終行に移動

Sub LastRow()
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  Application.Cells(65536, 1).End(xlUp).Select
End Sub
ヒント1 2行目以降にデータが入力されているにもかかわらず、最初の行を選択する場合があります。
ヒント2 Excel 2007では、どうでしょうか?
答え

このページの上

問題9 選択したセルの英字の小文字を大文字にする

Sub Upper()
  Dim r As Range

  For Each r In Selection
    r.Value = StrConv(r.Value, vbUpperCase)
  Next r
End Sub
ヒント! 実行時エラーになることもあります。(オブジェクトは、このプロパティまたはメッソドをサポートしていません。)
答え

このページの上

問題10 アクティブブックの空白のワークシートを削除する

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
ヒント! 保護なしでもシートを削除できない場合があります。
注意 CountAは罫線や図形があるかは判断しません。sh.PageSetup.Pages.Count > 0の方が良いでしょう。
答え

このページの上

問題11 最近使用したファイルのリストを作成する

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

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

  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

  ExistsSheet = False
  For Each sh In ActiveWorkbook.Sheets ' すべてのシート
    If UCase(sh.Name) = UCase(SheetName) Then
      ExistsSheet = True
      Exit Function
    End If
  Next sh
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
ヒント1 OSはWindowsです。ブック名は?
ヒント2 シート名は?
答え

このページの上

問題12 選択しているセルのアドレスを表示

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
ヒント! セルを選択してても、イミディエイトウィンドウには、何も表示されません。
答え

このページの上

問題13 割り算、商、余りを求める

Sub DivSample()
  Dim n As Variant   ' 入力用の数字
  Dim a As Double    ' 計算用の数字
  Dim 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
ヒント! 入力した数字によっては、実行時エラーになる場合があります。
答え

このページの上

問題14 指定した年が閏年か判定する

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
ヒント! この関数は引数のpYearを省略すると、すべてTrueになります。
答え

このページの上

問題15 すべてのハイパーリンクを削除する

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
ヒント! ハイパーリンクが2個以上あると、”インデックスが有効範囲にありません”のエラーになります。
答え

このページの上