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

ブックとシートの操作

ワークシートをコピーしてシート名を今日の日付にするには？

Book1.xlsのSheet1を最後のワークシートの後ろへコピーして、シート名を設定するサンプルです。

Sub Test()
    Dim oSheet1 As Worksheet
    Dim oSheet2 As Worksheet
    Dim sSheetName As String
    Dim obj As Object

    'コピー元シートの設定
    Set oSheet1 = Workbooks("Book1.xls").Sheets("Sheet1")

    'コピー先シートの設定(このシートの後ろにコピーします)
    With Workbooks("Book1.xls")
        Set oSheet2 = .Worksheets(.Worksheets.Count)
    End With

    'コピー先シート名の設定(今日の日付を使います)
    sSheetName = Format$(Date, "m""月""d""日""")

    'コピー先シートの有無をチェックします
    Set obj = GetItemByName(oSheet2.Parent.Worksheets, sSheetName)
    If Not (obj Is Nothing) Then
        MsgBox sSheetName & " のシートは既に存在します。", vbExclamation
        Exit Sub
    End If

    'シートをコピーします
    oSheet1.Copy after:=oSheet2

    'コピーしたシートに名前を設定します
    ActiveSheet.Name = sSheetName
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

セル範囲の操作

重複データを削除するには？

AdvancedFilterを使って、A1:A100のデータから重複を除いたデータをB列にコピーするサンプルです。1行目は列見出しである必要があります。

Sub Test()
    ActiveWorkbook.Sheets("Sheet1").Select
    ActiveSheet.Range("A1:A100").AdvancedFilter _
        action:=xlFilterCopy, _
        copyToRange:=ActiveSheet.Range("B1"), _
        unique:=True
End Sub

Excel97ではフィルタオプションの設定で異常終了するケースがあるので、注意してください。
フィルタ結果をその場所に表示し、結果が全件の場合、別シートに移動してメニューやツールバーを操作すると発生します。

空白行を削除するには？

AutoFilterを使い、A列が空白以外であるデータを別のシートへコピーするサンプルです。1行目は列見出しである必要があります。

Sub Test()
    Dim oRange_Input As Range, oRange_Output As Range

    Application.ScreenUpdating = False

    'コピー元とコピー先の設定
    Set oRange_Input = Sheets("Sheet1").Range("A1:E100")
    Set oRange_Output = Sheets("Sheet2").Range("A1")

    'コピー先シートの初期化
    oRange_Output.Worksheet.Cells.ClearContents

    'A列が空白以外のセルを抽出
    oRange_Input.Worksheet.AutoFilterMode = False
    oRange_Input.AutoFilter Field:=1, Criteria1:="<>"

    '抽出結果をコピー
    oRange_Input.Copy oRange_Output

    'オートフィルタを解除
    oRange_Input.Worksheet.AutoFilterMode = False

    Application.ScreenUpdating = True
End Sub


もう一つ、ちょっと難しくなりますが・・・
AutoFilterを使い、A列が空白であるデータを削除するサンプルです。1行目は列見出しである必要があります。

Sub Test()
    Dim oRange_Input As Range

    '対象範囲の設定
    Set oRange_Input = Sheets("Sheet1").Range("A1:A100")

    If oRange_Input.Rows.Count = 1 Then
        MsgBox "データがありません"
        Exit Sub
    End If

    Application.ScreenUpdating = False

    'A列が空白である行を抽出
    oRange_Input.Worksheet.AutoFilterMode = False
    oRange_Input.AutoFilter Field:=1, Criteria1:="="

    'データ範囲の行を取得
    With oRange_Input.Resize(oRange_Input.Rows.Count - 1).Offset(1).EntireRow

        '抽出結果があれば削除する
        If .Height = 0 Then
            MsgBox "空白行はありません"
        Else
            .Delete
        End If
    End With

    'オートフィルタを解除
    oRange_Input.Worksheet.AutoFilterMode = False

    Application.ScreenUpdating = True
End Sub

DAOを使いワークシートに対してSQLを実行するには？

DAOを使ってExcelファイルに対してSQLを実行する方法には、MDBファイルにExcelファイルをアタッチする方法と、ExcelファイルをDBとして開く方法があります。DAOの利用は、準備は多少面倒ですが、汎用性があり、性能も比較的良いです。

以下のサンプルでは、ExcelファイルをDBとして開き、グループ集計のSQLを実行し、結果をワークシートへ出力しています。

'DAOサンプル - Excel用データアクセスドライバ利用（Excel95）

'準備として、Office95Proの中のDAO3.0とExcel用データアクセスドライバを
'セットアップし、モジュールシートでDAO 3.0 Object Libraryを参照設定しました。

'ヘルプの「目次」-「Microsoft データ アクセス オブジェクト(DAO)」-
'「Microsoft Jet ISAM ドライバを使用する」-
'「DAO を使って Excel のワークシートまたはブックのデータへアクセスする」
'を参照しました。

Option Explicit

'SQL実行サンプルマクロ（Excel95）

Sub Sample_DAOExcel()
    Dim sFileName As String
    Dim sTableName As String
    Dim sSql As String
    Dim oRange_Output As Range

    sFileName = "D:\My Documents\Data1.xls"
    sTableName = "Table1"

    '見出し行を含むデータ範囲に名前を定義します
    'これがテーブル名になります
    Workbooks.Open sFileName
    ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Name = sTableName
    ActiveWorkbook.Close True

    'SQL文
    sSql = "SELECT 地区番号, 店番号, SUM(金額) As 金額合計 " & _
        " FROM [Table1] GROUP BY 地区番号, 店番号;"

    '出力用シートの設定
    Set oRange_Output = Worksheets("Sheet10").Range("A1")
    oRange_Output.Worksheet.Cells.Clear

    DAOExecuteSQL1 sFileName, sTableName, sSql, oRange_Output, True
End Sub


'DAO利用のSQL実行マクロ

Sub DAOExecuteSQL1(sFileName As String, sTableName As String, _
        sSql As String, oRange_Output As Range, bOutputHeader As Boolean)
    Dim db1 As Database
    Dim rs As Recordset
    Dim i As Integer

    On Error GoTo ErrorHandler

    'ブックをオープン
    Set db1 = OpenDatabase(sFileName, False, False, "EXCEL 5.0;")

    'クエリー実行
    Set rs = db1.OpenRecordset(sSql)

    If bOutputHeader Then
        'フィールド名を出力
        For i = 0 To rs.Fields.Count - 1
            oRange_Output.Cells(1, i + 1).Value = rs.Fields(i).Name
        Next
        'セルへ出力
        oRange_Output.Cells(2, 1).CopyFromRecordset rs
    Else
        'セルへ出力
        oRange_Output.CopyFromRecordset rs
    End If
    rs.Close
    Set rs = Nothing

    'ブックをクローズ
    db1.Close
    Set db1 = Nothing
    Exit Sub

ErrorHandler:
    MsgBox Error(Err), vbExclamation
    If Not (rs Is Nothing) Then
        rs.Close
        Set rs = Nothing
    End If
    If Not (db1 Is Nothing) Then
        db1.Close
        Set db1 = Nothing
    End If
End Sub

実行制御

他のアプリケーションのファイルを開くには？

手軽な方法としてはDOSのSTARTコマンドを使う方法があります。

Sub Sample_START()
    Shell "START ""C:\My Documents\Test.txt""", 2
End Sub


または、WindowsAPIのShellExecuteを使います。以下はExcel95/97用のサンプルコードです。

Option Explicit

Private Type SHELLEXECUTEINFO
    cbSize        As Long
    fMask         As Long
    hwnd          As Long
    lpVerb        As String
    lpFile        As String
    lpParameters  As String
    lpDirectory   As String
    nShow         As Long
    hInstApp      As Long
    lpIDList      As Long
    lpClass       As String
    hkeyClass     As Long
    dwHotKey      As Long
    hIcon         As Long
    hProcess      As Long
End Type

Private Const SEE_MASK_FLAG_NO_UI = &H400
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SW_SHOWNORMAL = &H1

Private Declare Function ShellExecuteEx Lib "shell32.dll" ( _
    ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

'ファイルを開く関数
Public Function MyFileOpen(ByVal sFileName As String) As Long
    Dim sei As SHELLEXECUTEINFO
    With sei
        .cbSize = 60
        .fMask = SEE_MASK_FLAG_NO_UI
        .hwnd = GetDesktopWindow()
        .lpVerb = "open"
        .lpFile = sFileName
        .lpParameters = ""
        .lpDirectory = ""
        .nShow = SW_SHOWNORMAL
    End With
    If ShellExecuteEx(sei) = 0 Then
        MyFileOpen = 0
    Else
        MyFileOpen = 1
    End If
End Function

'ファイルを開く関数（プロセスハンドルを返す）
'プロセスハンドルは後でCloseHandle APIを使いクローズします。
Public Function MyFileOpen_Process(ByVal sFileName As String) As Long
    Dim sei As SHELLEXECUTEINFO
    With sei
        .cbSize = 60
        .fMask = SEE_MASK_FLAG_NO_UI Or SEE_MASK_NOCLOSEPROCESS
        .hwnd = GetDesktopWindow()
        .lpVerb = "open"
        .lpFile = sFileName
        .lpParameters = ""
        .lpDirectory = ""
        .nShow = SW_SHOWNORMAL
    End With
    If ShellExecuteEx(sei) = 0 Then
        MyFileOpen_Process = 0
    Else
        MyFileOpen_Process = sei.hProcess
    End If
End Function


Sub Test_ShellExecuteEx()
    Dim iRet As Long
    iRet = MyFileOpen("C:\My Documents\Test.txt")
    If iRet = 0 Then
        MsgBox "エラーが発生しました。", vbExclamation
    End If
End Sub


Excel5.0用のサンプルコードです。

Option Explicit

Private Const SW_SHOWNORMAL = &h1

Private Declare Function ShellExecute Lib "SHELL.DLL" ( _
    ByVal hwnd As Integer, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Integer) As Integer

Private Declare Function GetDesktopWindow Lib "USER" () As Integer

Public Function MyFileOpen16(ByVal sFileName As String) As Integer
    MyFileOpen16 = ShellExecute(GetDesktopWindow(), _
        "open", sFileName, "", "", SW_SHOWNORMAL)
End Function

Sub Test_ShellExecute16()
    Dim iRet As Integer
    iRet = MyFileOpen16("C:\My Documents\Test.txt")
    If iRet <= 32 Then
        MsgBox "エラーが発生しました。", vbExclamation
    End If
End Sub

Shell関数で起動したプログラムの終了を待つには？

WindowsAPIを使います。以下はExcel95/97用のサンプルコードです。

Option Explicit

Private Declare Function OpenProcess Lib "kernel32" ( _
    ByVal dwAccess As Long, ByVal fInherit As Long, _
    ByVal IDProcess As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
    ByVal hProcess As Long, ByRef lpdwExitCode As Long) As Long

Private Const PROCESS_QUERY_INFORMATION = &h400&
Private Const STILL_ACTIVE = &h103&

Sub Test_32()
    Dim IDProcess As Long
    Dim hProcess As Long
    Dim dwExitCode As Long
    Dim iRet As Long

    'メモ帳の起動
    On Error Resume Next
    IDProcess = Shell("NOTEPAD.EXE", 1)
    If Err <> 0 Then
        On Error GoTo 0
        AppActivate Application.Caption
        MsgBox "エラーが発生しました。(Shell)", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    '起動したプログラムのプロセスハンドルを取得
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 1, IDProcess)
    If hProcess = 0 Then
        AppActivate Application.Caption
        MsgBox "エラーが発生しました。(OpenProcess)", vbExclamation
        Exit Sub
    End If

    Do

        'オペレーティングシステムに制御を渡す
        DoEvents

        'プロセスの終了状態を取得
        iRet = GetExitCodeProcess(hProcess, dwExitCode)
        If iRet = 0 Then
            iRet = CloseHandle(hProcess)
            AppActivate Application.Caption
            MsgBox "エラーが発生しました。(GetExitCodeProcess)", vbExclamation
            Exit Sub
        End If

        'プロセスが継続している間、繰り返す
    Loop While (dwExitCode = STILL_ACTIVE)

    'プロセスハンドルをクローズ
    iRet = CloseHandle(hProcess)
    If iRet = 0 Then
        AppActivate Application.Caption
        MsgBox "エラーが発生しました。(CloseHandle)", vbExclamation
        Exit Sub
    End If

    AppActivate Application.Caption
    MsgBox " 終了しました。", vbInformation
End Sub


Excel5.0用のサンプルコードです。

Option Explicit

Private Declare Function GetModuleUsage Lib "Kernel" ( _
    ByVal hModule As Integer) As Integer

Sub Test_16()
    Dim hInst As Integer

    'メモ帳の起動
    On Error Resume Next
    hInst = Shell("NOTEPAD.EXE", 1)
    If (Err <> 0) Or (hInst < 32) Then
        On Error GoTo 0
        AppActivate Application.Caption
        MsgBox "エラーが発生しました。(Shell)", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    'プログラムが継続している間、繰り返す
    Do While GetModuleUsage(hInst) <> 0
        DoEvents
    Loop

    AppActivate Application.Caption
    MsgBox " 終了しました。", vbInformation
End Sub


Excelのサポート情報にも同様のサンプルがあるのですが、なぜかCloseHandleしていません。VBのサポート情報の方では、しているのに・・・プロセスオブジェクトが残ってしまうということはないのでしょうか？

ユーザー操作でExcelを終了できなくするには？

コントロールメニューを使用できないようにするにはWindowsAPIを使います。[ファイル]メニューやAlt+F4キーは、VBAの機能を使い、必要に応じてカスタマイズが可能です。ブックのウィンドウは、ブックの保護によって操作を禁止できます。

以下はコントロールメニューを使用不可にする、Excel95/97用のサンプルコードです。ただし、Excel95の場合は[X]ボタンは表示されたままになります。

'コントロールメニューを無効にするマクロ(Excel95/97)

Option Explicit

Private Const GWL_STYLE As Long = -16
Private Const WS_SYSMENU As Long = &h80000

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" ( _
    ByVal hwnd As Long) As Long

'コントロールメニューを無効にするマクロ
Sub HideControlMenu32()
    Dim hwnd As Long
    Dim iWindowStyle As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", Application.Caption)
    iWindowStyle = GetWindowLong(hwnd, GWL_STYLE)
    iRet = SetWindowLong(hwnd, GWL_STYLE, _
        iWindowStyle And (Not WS_SYSMENU))
    iRet = DrawMenuBar(hwnd)
End Sub

'コントロールメニューを有効にするマクロ
Sub ShowControlMenu32()
    Dim hwnd As Long
    Dim iWindowStyle As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", Application.Caption)
    iWindowStyle = GetWindowLong(hwnd, GWL_STYLE)
    iRet = SetWindowLong(hwnd, GWL_STYLE, _
        iWindowStyle Or WS_SYSMENU)
    iRet = DrawMenuBar(hwnd)
End Sub


もう1つ、Excel95/97用のサンプルコードです。

'閉じるメニューを削除するマクロ(Excel95/97)

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMenu Lib "user32" ( _
    ByVal hwnd As Long, ByVal fRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" ( _
    ByVal hmenu As Long, ByVal uItem As Long, _
    ByVal fuFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" ( _
    ByVal hwnd As Long) As Long

Private Const SC_CLOSE = &hf060

'閉じるメニューを削除するマクロ
Sub SystemMenu_DeleteClose()
    Dim hwnd As Long, hmenu As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", Application.Caption)
    hmenu = GetSystemMenu(hwnd, 0)
    iRet = DeleteMenu(hmenu, SC_CLOSE, 0)
    iRet = DrawMenuBar(hwnd)
End Sub

'システムメニューをリセットするマクロ
Sub SystemMenu_Reset()
    Dim hwnd As Long, hmenu As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", Application.Caption)
    hmenu = GetSystemMenu(hwnd, 1)
    iRet = DrawMenuBar(hwnd)
End Sub


Excel5.0用のサンプルコードです。

'コントロールメニューを無効にするマクロ(Excel5.0)

Option Explicit

Private Const GWL_STYLE As Long = -16
Private Const WS_SYSMENU As Long = &h80000

Private Declare Function FindWindow Lib "USER" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Integer
Private Declare Function GetWindowLong Lib "USER" ( _
    ByVal hwnd As Integer, ByVal nIndex As Integer) As Long
Private Declare Function SetWindowLong Lib "USER" ( _
    ByVal hwnd As Integer, ByVal nIndex As Integer, _
    ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "USER" ( _
    ByVal hwnd As Integer) As Integer

'コントロールメニューを無効にするマクロ
Sub HideControlMenu16()
    Dim hwnd As Integer
    Dim iWindowStyle As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", Application.Caption)
    iWindowStyle = GetWindowLong(hwnd, GWL_STYLE)
    iRet = SetWindowLong(hwnd, GWL_STYLE, _
        iWindowStyle And (Not WS_SYSMENU))
    iRet = DrawMenuBar(hwnd)
End Sub

'コントロールメニューを有効にするマクロ
Sub ShowControlMenu16()
    Dim hwnd As Integer
    Dim iWindowStyle As Long
    Dim iRet As Long
    hwnd = FindWindow("XLMAIN", Application.Caption)
    iWindowStyle = GetWindowLong(hwnd, GWL_STYLE)
    iRet = SetWindowLong(hwnd, GWL_STYLE, _
        iWindowStyle Or WS_SYSMENU)
    iRet = DrawMenuBar(hwnd)
End Sub

ファイルが使用中か調べるには？

Openステートメントを使い、ファイルのロックを試みるサンプルです。ロックに失敗した場合はファイルが開かれています。

さらに、読み取り専用で開かれた場合には直ちにファイルを閉じるようにしています。

'ファイルのロックを試す関数
Function TestFileLock(ByVal sFileName As String) As Long
    Dim iFileNo As Long

    If Dir$(sFileName) = "" Then
        TestFileLock = 2
        Exit Function
    End If

    iFileNo = FreeFile()
    On Error Resume Next
    Open sFileName For Binary Lock Read Write As #iFileNo
    If Err = 0 Then
        On Error GoTo 0
        Close #iFileNo
        TestFileLock = 0
    Else
        On Error GoTo 0
        TestFileLock = 1
    End If
End Function

'テストマクロ
Sub Sample_CheckUsed()
    Dim oBook As Workbook
    Dim sFileName As String
    Dim iRet As Long

    sFileName = "C:\My Documents\Book1.xls"

    'ファイルのロックを試みます
    iRet = TestFileLock(sFileName)

    Select Case iRet
        Case 0
        Case 1
            MsgBox "ファイルは開いています。", vbExclamation
            Exit Sub
        Case 2
            MsgBox "ファイルがありません。", vbExclamation
            Exit Sub
        Case Else
            Exit Sub
    End Select

    'ファイルを開きます
    Set oBook = Workbooks.Open(sFileName)

    '読み取り専用になっていた場合はファイルを閉じます
    If oBook.ReadOnly Then
        MsgBox "このブックは読み取り専用であるため使用できません。", _
            vbExclamation
        oBook.Close False
        Exit Sub
    End If

End Sub

メニューバーを非表示にするには？(Excel97)

メニューバーを非表示にするにはEnabledプロパティを設定します。（Visibleプロパティを設定しても非表示にはなりません。Visibleプロパティはメニューバーの変更の際に使用します。）

'ワークシートメニューバーを非表示にするマクロ
Sub WorksheetMenuBar_Hide()
    CommandBars("Worksheet Menu Bar").Enabled = False
End Sub

'ワークシートメニューバーを表示するマクロ
Sub WorksheetMenuBar_Show()
    CommandBars("Worksheet Menu Bar").Enabled = True
End Sub


'すべてのメニューバーを非表示にするマクロ
Sub AllMenuBar_Hide()
    Dim oCommandBar As CommandBar
    For Each oCommandBar In CommandBars
        If oCommandBar.Type = msoBarTypeMenuBar Then
            oCommandBar.Enabled = False
        End If
    Next
End Sub

'すべてのメニューバーを表示するマクロ
Sub AllMenuBar_Show()
    Dim oCommandBar As CommandBar
    For Each oCommandBar In CommandBars
        If oCommandBar.Type = msoBarTypeMenuBar Then
            oCommandBar.Enabled = True
        End If
    Next
End Sub

ショートカットメニューを非表示にするには？(Excel97)

ショートカットメニューを非表示にするにはEnabledプロパティを設定します。 ショートカットメニューには同名のものが複数あるので（"Cell"など）、インデックス番号で指定します。メニュー名やインデックス番号はマクロで調べることができます。

なお、Excel97の初期版ではツールバーのショートカットメニューは操作できません。

'ショートカットメニューの一覧をイミディエイトに出力するマクロ
Sub ShortcutMenus()
    Dim oCommandBar As CommandBar
    For Each oCommandBar In Application.CommandBars
        If oCommandBar.Type = msoBarTypePopup Then
            Debug.Print oCommandBar.Index, oCommandBar.Name, _
                oCommandBar.NameLocal
        End If
    Next
End Sub


'ワークシートのショートカットメニューを無効にするマクロ
'標準表示と改ページプレビューのセル、行、列を設定します
Sub WorksheetShortcutMenu_Disable()
    Dim i As Long
    For i = 21 To 26
        CommandBars(i).Enabled = False
    Next
End Sub

'ワークシートのショートカットメニューを無効にするマクロ
Sub WorksheetShortcutMenu_Enable()
    Dim i As Long
    For i = 21 To 26
        CommandBars(i).Enabled = True
    Next
End Sub


'すべてのショートカットメニューを無効にするマクロ
Sub AllShortcutMenu_Disable()
    Dim oCommandBar As CommandBar
    For Each oCommandBar In Application.CommandBars
        If oCommandBar.Type = msoBarTypePopup Then
            oCommandBar.Enabled = False
        End If
    Next
End Sub

'すべてのショートカットメニューを有効にするマクロ
Sub AllShortcutMenu_Enable()
    Dim oCommandBar As CommandBar
    For Each oCommandBar In Application.CommandBars
        If oCommandBar.Type = msoBarTypePopup Then
            oCommandBar.Enabled = True
        End If
    Next
End Sub

[戻る]