[一覧] [入門編1] [入門編2] [入門編3] [実践編] [トラブル編]

ブックとシートの操作

同じ名前のシートがあるかどうか調べるには？

アクティブブックのWorksheetsコレクションを、For Each Nextループで調べるサンプルです。

Sub SheetCheck1()
    Dim oSheet As Worksheet
    Dim sSheetName As String
    Dim bFound As Boolean

    sSheetName = "Sheet1"

    bFound = False
    For Each oSheet In ActiveWorkbook.Worksheets
        If oSheet.Name = sSheetName Then
            bFound = True
            Exit For
        End If
    Next

    If bFound Then
        MsgBox sSheetName & "は既に存在します。"
    Else
        MsgBox sSheetName & "はありません。"
    End If
End Sub


エラートラップ処理を利用するサンプルです。

Sub SheetCheck2()
    Dim sSheetName As String
    Dim oSheet As Worksheet

    sSheetName = "Sheet1"
    Set oSheet = GetItemByName(ActiveWorkbook.Worksheets, sSheetName)

    If oSheet Is Nothing Then
        MsgBox sSheetName & " はありません。"
    Else
        MsgBox sSheetName & " は既に存在します。"
    End If
End Sub

Function GetItemByName(ByVal oCollection As Object, _
        ByVal sItemName As String) As Object
    Set GetItemByName = Nothing
    On Error Resume Next
    Set GetItemByName = oCollection.Item(sItemName)
    On Error GoTo 0
End Function

アクティブシートの名前を今日の日付にするには？

Date関数で今日の日付を取得し、Format関数で目的の形式の文字列にします。

'アクティブシートの名前を今日の日付にするサンプル
'すでに同じ名前のシートがある場合はエラーで中断します

Sub SetSheetName_Today()
    Dim sName As String

    sName = Format$(Date, "m""月""d""日(""aaa"")""")
    ActiveSheet.Name = sName
End Sub

シートを昇順に並び替えるには？

直接選択法というシンプルな並び替え方法を使ったサンプルです。

まず全体の中で最小値を見つけて先頭に移動します。
次に2番目以降の中で、最小値を見つけて2番目に移動します。
次に3番目以降の中で、最小値を見つけて3番目に移動します。
これを繰り返すと並び替えができます。

'ワークシートを昇順に並び替えるサンプル

Sub Sample_SortWorksheet()
    Dim sName As String
    Dim iCount As Integer
    Dim i As Integer
    Dim j As Integer

    Application.ScreenUpdating = False

    iCount = Worksheets.Count

    For i = 1 To iCount - 1

        'シート名の最小値を取得します
        sName = Worksheets(i).Name
        For j = i + 1 To iCount
            If Worksheets(j).Name < sName Then
                sName = Worksheets(j).Name
            End If
        Next

        'シート名が最小のシートを現在の先頭に移動します
        Worksheets(sName).Move before:=Worksheets(i)

    Next

    Worksheets(1).Select

    Application.ScreenUpdating = True

End Sub

ウィンドウの左上隅のセルを設定するには？

ScrollRowとScrollColumnプロパティを使います。ただし、ウィンドウ枠固定がされている場合は、スクロール範囲の左上隅のセルの設定になります。

'Sheet1のC6を選択し、B5をアクティブウィンドウの左上隅に
'表示するサンプルです
Sub Sample_WindowLeftTopCell()
    Application.ScreenUpdating = False
    Sheets("Sheet1").Select
    ActiveSheet.Range("C6").Select
    With ActiveWindow
        .ScrollRow = 5
        .ScrollColumn = 2
    End With
    Application.ScreenUpdating = True
End Sub

特定のセル範囲をすべて表示させるには？

表示させたい範囲を選択して、ZoomプロパティにTrueを設定します。Sheet1のA1:H20を表示するサンプルです。

'特定のセル範囲をすべて表示させるサンプル

'Sheet1!A1:H20を表示するサンプルです
'ウィンドウは分割されていないという前提です

Sub Sample_Zoom()

    Application.ScreenUpdating = False

    '表示させる範囲を選択します
    Sheets("Sheet1").Select
    ActiveSheet.Range("A1:H20").Select

    'ブックウィンドウを最大化、ズームを100%、表示範囲を設定します
    With ActiveWindow
        .WindowState = xlMaximized
        .Zoom = 100
        .ScrollRow = 1
        .ScrollColumn = 1
    End With

    'ウィンドウにすべて表示されていない場合、ZoomにTrueを設定します
    With ActiveWindow.VisibleRange
        If (.Rows.Count <= Selection.Rows.Count) Or _
            (.Columns.Count <= Selection.Columns.Count) Then
            ActiveWindow.Zoom = True
        End If
    End With

    ActiveSheet.Range("A1").Select

    Application.ScreenUpdating = True

End Sub

ワークシートのデータをCSV形式で保存しましたが、文字列が""で囲まれません。なぜですか？

CSV形式にもいろいろあります。Excelでは基本的には文字列はそのまま出力されます。都合が悪い場合は、他の方法で実現するしかありません。

タブ区切りで出力後に他のツールで変換する、VBAでファイル出力のプログラムを書く、Accessで出力する、などの方法があります。

特定のセル範囲だけをテキストファイルに保存したり、ファイルから読み込むには？

Excelには、特定のセル範囲だけを保存したり、ファイルから特定のセル範囲へ読み込む機能はありません。セル範囲を別のブックへコピーして保存したり、読み込んだ後、特定の範囲へコピーする方法が比較的容易で、性能的にも有利です。

少量のデータであれば、VBAのファイル入出力の機能（Input、Write、Print等）を使う方法もあります。

特定のシートだけをファイルに保存するには？

シートをコピーして新規ブックを作成し、名前を付けて保存するサンプルです。

'特定のシートだけをファイルに保存するサンプル

'すでに同名のファイルがある場合は、確認のメッセージが表示されます
'キャンセルした場合はエラーが発生しマクロは中断します

Sub Sample_SaveSheet()
    Dim sFileName As String

    'ファイル名を設定します
    sFileName = "C:\My Documents\D" & Format$(Date, "yymmdd") & ".xls"

    'シートをコピーして新規ブックを作成します
    Sheets(Array("Sheet1", "Sheet2")).Copy

    '作成したブックを保存します
    ActiveWorkbook.SaveAs sFileName
End Sub

ブックが開いているか調べるには？

Workbooksコレクションを、For Each Nextループで調べるサンプルです。

Sub BookCheck1()
    Dim oBook As Workbook
    Dim sBookName As String
    Dim bFound As Boolean

    sBookName = "Book1.xls"

    bFound = False
    For Each oBook In Workbooks
        If oBook.Name = sBookName Then
            bFound = True
            Exit For
        End If
    Next

    If bFound Then
        MsgBox sBookName & " は開いています。"
    Else
        MsgBox sBookName & " は開いていません。"
    End If
End Sub


エラートラップ処理を利用するサンプルです。

Sub BookCheck2()
    Dim sBookName As String
    Dim oBook As Workbook

    sBookName = "Book1.xls"
    Set oBook = GetItemByName(Workbooks, sBookName)

    If oBook Is Nothing Then
        MsgBox sBookName & " は開いていません。"
    Else
        MsgBox sBookName & " は開いています。"
    End If
End Sub

Function GetItemByName(ByVal oCollection As Object, _
        ByVal sItemName As String) As Object
    Set GetItemByName = Nothing
    On Error Resume Next
    Set GetItemByName = oCollection.Item(sItemName)
    On Error GoTo 0
End Function

ファイルの有無をチェックするには？

Dir関数を使います。Dir関数はファイルがある場合はそのファイル名（フォルダ名は含まない）を返し、ない場合は長さ0の文字列を返します。

Sub FileCheck()
    Dim sFileName As String
    Dim sFileName2 As String

    sFileName = "C:\My Documents\Book1.xls"
    sFileName2 = Dir$(sFileName)
    If sFileName2 = "" Then
        MsgBox sFileName & " は存在しません。"
    Else
        MsgBox sFileName & " はすでに存在します。"
    End If
End Sub

ファイルのコピー、移動、削除を行うには？

FileCopy、Name、Kill ステートメントを使います。

現在開いているブックのコピーはFileCopyではできません。SaveCopyAsメソッドを使います。

フォルダ内のすべてのブックを処理するには？(Windows)

フォルダ内のファイルを列挙するにはDir関数を使います。

このマクロブックがあるフォルダのDATAフォルダ内の、"DT"で始まるファイルを1つ1つ開いて処理を行うサンプルです。

Sub Sample_Workbooks()
    Dim sFolderName As String
    Dim sFileName As String

    '対象フォルダの設定
    sFolderName = ThisWorkbook.Path & "\DATA\"

    '"DT"で始まるファイル名を取得
    sFileName = Dir$(sFolderName & "DT*.xls")

    'ファイル名の列挙が終わるまで実行します
    Do Until sFileName = ""

        'ブックを開きます
        Workbooks.Open sFolderName & sFileName

        'ブックに対する処理(サンプル)
        Sample_Proc

        '次のファイル名を取得
        sFileName = Dir$()
    Loop

End Sub

'ブックに対する処理(サンプル)
'ブック名をデバッグウィンドウへ出力し、閉じます
Sub Sample_Proc()
    Debug.Print ActiveWorkbook.Name
    ActiveWorkbook.Close False
End Sub

セル範囲の操作

セルの値によって色を付けるには？

Excel97では条件付き書式という機能を使っても可能です。

A1:A100の範囲で100以上のセルを赤にするサンプルです。

Sub Sample_SetColor()
    Dim r As Range

    ActiveWorkbook.Sheets("Sheet1").Select
    ActiveSheet.Range("A1:A100").Select

    '選択範囲の色を消去
    Selection.Interior.ColorIndex = xlNone

    For Each r In Selection.Cells
        'セルの値が100以上のとき色を赤(3)にする
        If r.Value >= 100 Then
            r.Interior.ColorIndex = 3
        End If
    Next
End Sub

キー項目が変化したら改ページを挿入するには？

ワークシートで行単位に処理を行う場合、1行1行、セルの値を調べながら繰り返す方法と、あらかじめデータの最終行を調べ、その行まで繰り返す方法があります。それぞれのサンプルを書いてみました。

'キー項目が変化したら改ページを挿入するサンプル

'データはSheet1にあり、1行目が列見出し、2行目からデータが連続してある
'という前提です

'空白セルまで繰り返す方法

Sub Sample_SetPageBreak1()
    Dim oSheet As Worksheet
    Dim vKey As Variant
    Dim vKey_Old As Variant
    Dim iColumn_Key As Long
    Dim iRow As Long

    Application.ScreenUpdating = False

    '対象シートの設定
    Set oSheet = Sheets("Sheet1")

    '改ページのクリア
    oSheet.Cells.PageBreak = xlNone

    'キー項目の列番号を設定します
    iColumn_Key = 1

    'データの開始行を設定します
    iRow = 2

    '1件目のキー値を取得
    vKey = oSheet.Cells(iRow, iColumn_Key).Value
    vKey_Old = vKey

    'キー値が空値になるまで繰り返します
    Do Until IsEmpty(vKey)

        'キーが変化したら改ページを挿入します
        If vKey <> vKey_Old Then
            oSheet.Rows(iRow).PageBreak = xlManual
            vKey_Old = vKey
        End If

         '次のキー値を取得
        iRow = iRow + 1
        vKey = oSheet.Cells(iRow, iColumn_Key).Value
    Loop

    Application.ScreenUpdating = True

End Sub


'あらかじめ最終行を取得して繰り返す方法

Sub Sample_SetPageBreak2()
    Dim oSheet As Worksheet
    Dim vKey As Variant
    Dim vKey_Old As Variant
    Dim iColumn_Key As Long
    Dim iRow_Start As Long
    Dim iRow_End As Long
    Dim iRow As Long

    Application.ScreenUpdating = False

    '対象シートの設定
    Set oSheet = Sheets("Sheet1")

    '改ページのクリア
    oSheet.Cells.PageBreak = xlNone

    'キー項目の列番号を設定します
    iColumn_Key = 1

    'データの開始行を設定します
    iRow_Start = 2

    'データの最終行を取得します(CurrentRegionを使用)
    iRow_End = oSheet.Cells(1, 1).CurrentRegion.Rows.Count

    '1件目のキー値を取得
    vKey_Old = oSheet.Cells(iRow_Start, iColumn_Key).Value

    '2件目から最終行まで繰り返します
    For iRow = iRow_Start + 1 To iRow_End

        'キー値を取得します
        vKey = oSheet.Cells(iRow, iColumn_Key).Value

        'キーが変化したら改ページを挿入します
        If vKey <> vKey_Old Then
            oSheet.Rows(iRow).PageBreak = xlManual
            vKey_Old = vKey
        End If
    Next

    Application.ScreenUpdating = True

End Sub

5行目以降のセルをクリアするには

ワークシートの最終行は、ActiveSheet.Rows.Count で取得できます。これはアクティブシートのすべての行の数という意味になります。

Excel95では最終行は、16384行です。Sample_ClearRow1では"5:16384"というセル参照文字列を作成し、その範囲をクリアしています。Sample_ClearRow2では、5行目から(16384 - 5 + 1)行分をクリアしています。

Sub Sample_ClearRow1()
    Dim iRow_Start As Long
    Dim iRow_End As Long

    Worksheets("Sheet1").Select

    iRow_Start = 5
    iRow_End = ActiveSheet.Rows.Count

    ActiveSheet.Rows(CStr(iRow_Start) & ":" & CStr(iRow_End)).Clear

End Sub

Sub Sample_ClearRow2()
    Dim iRow_Start As Long
    Dim iRow_End As Long

    Worksheets("Sheet1").Select

    iRow_Start = 5
    iRow_End = ActiveSheet.Rows.Count

    ActiveSheet.Rows(5).Resize(iRow_End - iRow_Start + 1).Clear

End Sub

データの最終行を知るには？

EndとCurrentRegionを使ったサンプルマクロです。

'アクティブシートのA列の最終セルを選択するサンプルマクロ

Sub MyEndUp()

    Sheets("Sheet1").Select

    'A列の最下行のセルを取得し...
    With ActiveSheet.Cells(ActiveSheet.Rows.Count, 1)

        'そのセルが空白であれば...
        If IsEmpty(.Value) Then

            'Endで上へジャンプします
            .End(xlUp).Select

        Else

            '空白でなければ、そのセルを選択します
            .Select

        End If
    End With
End Sub


'アクティブシートのA列の最終セルの次行を選択するサンプルマクロ
Sub MyEndUp2()

    Sheets("Sheet1").Select

    'A列の最下行のセルを取得し...
    With ActiveSheet.Cells(ActiveSheet.Rows.Count, 1)

        'そのセルが空白であれば...
        If IsEmpty(.Value) Then

            'Endで上へジャンプし...
            With .End(xlUp)

                'そのセルが空白であれば...
                If IsEmpty(.Value) Then

                    'そのセルを選択します
                    .Select

                Else

                    '空白でなければ、その次行のセルを選択します
                    .Offset(1, 0).Select

                End If
            End With
        Else

            '空白でなければ、エラーを表示します
            MsgBox "これ以上データを追加できません。", vbExclamation
            Exit Sub

        End If
    End With
End Sub


'アクティブシートのA列の最終セルを選択するサンプルマクロ

'A1からデータが連続して存在していることが前提です

Sub MyCurrentRegion()

    Sheets("Sheet1").Select

    'A1から連続してデータのある範囲を取得し...
    With ActiveSheet.Range("A1").CurrentRegion

        '最終行のセルを選択します
        .Cells(.Rows.Count, 1).Select

    End With
End Sub


'アクティブシートのA列の最終セルの次行を選択するサンプルマクロ

'A1からデータが連続して存在していることが前提です

Sub MyCurrentRegion2()

    Sheets("Sheet1").Select

    'A1から連続してデータのある範囲を取得し...
    With ActiveSheet.Range("A1").CurrentRegion

        '範囲の最終行がワークシートの最終行でなければ...
        If .Rows.Count < ActiveSheet.Rows.Count Then

            '最終行+1のセルを選択します
            .Cells(.Rows.Count + 1, 1).Select

        Else

            '範囲の最終行がワークシートの最終行の場合はエラーを表示します
            MsgBox "これ以上データを追加できません。", vbExclamation
            Exit Sub

        End If
    End With
End Sub

1行おきにセルを選択するには？

Unionを使ったサンプルです。

'2行目から2行ずつ1行おきに選択するサンプルマクロ
Sub Sample_GetRowsStepN()
    GetRowsStepN( _
        oRange_Target:=ActiveSheet.Range("A1").CurrentRegion, _
        iStart:=2, iRowCount1:=2, iRowCount2:=1).Select
End Sub

'n行おきの範囲を取得する関数(引数チェックなし)

'oRange_Target: 対象範囲
'iStart       : 開始行
'iRowCount1   : 選択行数
'iRowCount2   : 間隔行数

Function GetRowsStepN(oRange_Target As Range, iStart As Long, _
        iRowCount1 As Long, iRowCount2 As Long) As Range
    Dim oRange_Result As Range
    Dim iStep As Long
    Dim i As Long

    'ステップ数を計算
    iStep = iRowCount1 + iRowCount2

    '最初の行を取得し、結果の範囲に設定
    Set oRange_Result = oRange_Target.Rows(iStart).Resize(iRowCount1)

    '次の行から最終行まで、指定間隔で繰り返す
    For i = iStart + iStep To oRange_Target.Rows.Count Step iStep

        '結果の範囲に行を追加
        Set oRange_Result = Application.Union(oRange_Result, _
            oRange_Target.Rows(i).Resize(iRowCount1))

    Next

    '結果の範囲を戻り値に設定
    Set GetRowsStepN = oRange_Result

End Function

セルのコピー貼り付けが、非常に遅いのですが？

処理の間は再計算モードを手動にしてください。

他に、画面更新の抑止でも性能が向上します。

Sub Copy_Calc_Off()
    Dim iOldCalculation As Integer

    '画面更新の抑止
    Application.ScreenUpdating = False

    '現在の再計算モードの取得
    iOldCalculation = Application.Calculation

    '再計算モードを手動に設定
    Application.Calculation = xlManual

    'コピー貼り付け
    Sheets("Sheet1").Range("A1:A10000").Copy
    Sheets("Sheet2").Range("A1").PasteSpecial xlValues

    '再計算モードの復元
    Application.Calculation = iOldCalculation

    '画面更新
    Application.ScreenUpdating = True
End Sub

[戻る]