2010/05/02

VBAでシートの有無を確認する

任意のシートの有無によって処理を分けたい場合に使えるサンプルコードです。

' シートの有無を確認する (1) '
Sub ChkSheetSample1()

Dim xWsheet As Worksheet
Dim xFlag As Boolean

For Each xWsheet In Worksheets
    If xWsheet.Name = "確認したいシート名" Then xFlag = True
Next xWsheet

If xFlag = True Then
    ' 該当のシートがある場合の処理 '
    MsgBox "あり"
Else
    ' 該当のシートがない場合の処理 '
    MsgBox "なし"
End If

End Sub
' シートの有無を確認する (2) '
Sub ChkSheetSample2()

Dim xWsheet As Worksheet

On Error Resume Next
Set xWsheet = Worksheets("確認したいシート名")
On Error GoTo 0

If xWsheet Is Nothing Then
    ' 該当のシートがない場合の処理 '
    MsgBox "なし"
Else
    ' 該当のシートがある場合の処理 '
    MsgBox "あり"
End If

End Sub

(1)は確認したいシートがあるか全てのシート内でチェックして、該当のシートがあればxFlagの値をTrueにセットして、該当のシートがある場合の処理を実行します。なお、ブール型(Boolean)の初期値はFalseなので、該当のシートがない場合は、xFlagの値はFalseのままとなり、シートがない場合の処理が実行されます。

(2)は確認したいシート名をSetステートメントでとりあえず代入しています。該当のシートがある場合は、xWsheetにオブジェクトが代入されて、シートがある場合の処理が実行されます。また、該当のシートがない場合は、xWsheetの値はNothingのままとなり、シートがない場合の処理が実行されます。

※ 任意のシート名をそのままSetステートメントに代入した場合、該当のシートがなければ、『実行時エラー '9' :インデックスが有効範囲にありません。』エラーが発生して処理が中断されてしまいます。従って、一旦、"On Error Resume Next"ステートメントでエラーメッセージを非表示にして先に進め、代入後、"On Error GoTo 0"で、先のエラー処理を無効にして(元の状態に戻して)います。

1 件のコメント:

  1. くおりあ様

    コードの共有ありがとうございました。
    現在以下Do While loopの繰り返し処理のコードの一部として活用させていただいているのですが、4周目で
    Worksheets("分割入力テンプレート").Activate でインデックスが有効範囲にありませんというエラーが表示されます。何が問題なのでしょうか?




    Option Explicit
    Sub 分割先テンプレートコピー()


    '変数宣言
    Dim パス名 As String
    Dim ファイル名 As String
    Dim 貼付行 As String
    Dim 選択範囲 As Range
    Dim xWsheet As Worksheet

    'ファイル名取得
    パス名 = ActiveWorkbook.Path & "¥分割コピー¥"
    ファイル名 = Dir(パス名 & "*.xlsx")

    'ブックコピー

    Do While ファイル名 <> ""
    Workbooks.Open パス名 & ファイル名

    On Error Resume Next
    Set xWsheet = Worksheets("分割入力テンプレート")
    On Error GoTo 0
    If xWsheet Is Nothing Then
    ' 該当のシートがない場合の処理 '
    ActiveWindow.Close
    Else
    ' 該当のシートがある場合の処理 '

    Worksheets("分割入力テンプレート").Activate

    Set 選択範囲 = Range("e10")
    Set 選択範囲 = 選択範囲.Resize(, 9)
    選択範囲.Select
    Selection.Copy
    ActiveWindow.ActivateNext
    貼付行 = Range("A65536").End(xlUp).Row + 1
    Range(Cells(貼付行, 1), Cells(貼付行, 1)).Select
    ActiveSheet.Paste


    ActiveWindow.ActivateNext
    ActiveWorkbook.Save
    ActiveWindow.Close



    End If

    ファイル名 = Dir()

    Loop




    End Sub

    返信削除