Attribute VB_Name = "Module1"
'■　マクロ５００連発＜第２段＞
'
'　ブックを開かずにデータを追加する
'
'  Copyright(C) 2000 Sunago
'
'　　このマクロを実行するには、参照可能なライブラリファイルとして
'  Microsoft ActiveX Data Objects 2.1 Library(ADO)または同等
'  ライブラリへの参照設定が必要です。
'
Option Explicit

Sub Macro1()
Dim Cnn As ADODB.Connection
Dim Rec As ADODB.Recordset
Dim Err1 As ADODB.Error
Dim strSQL As String
Dim strerr As String
Dim lngcnt As Long
Dim i As Integer

    'バージョンチェック
    If Ver9Check = False Then
        MsgBox "このバージョンのEXCELでは別途ADOライブラリを入手し、" & vbCr & _
                "インストールする必要があります。"
        Exit Sub
    End If
    
    Set Cnn = New ADODB.Connection
    On Error Resume Next
    Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
    'Excel97,2000のブックはExcel8.0で設定する
    Cnn.Properties("Extended Properties") = "Excel 8.0"
    Cnn.Open Path(ThisWorkbook.Path) & "266data.xls"
    On Error GoTo 0
    If Cnn.State <> adStateOpen Then
        strerr = "接続エラー(" & Cnn.ConnectionString & ")" & vbCr
        For Each Err1 In Cnn.Errors
            strerr = strerr & Err1.Description & "(Error:" & Err1.NativeError & ")" & vbCr
        Next
        MsgBox strerr
        Exit Sub
    End If
    
    Set Rec = New ADODB.Recordset
    Set Rec.ActiveConnection = Cnn
    Rec.Open "[Sheet1$]", , adOpenKeyset, adLockPessimistic, adCmdTable
    If Cnn.Errors.Count > 0 Then
        strerr = "オープンエラー(" & Rec.Source & ")" & vbCr
        For Each Err1 In Cnn.Errors
            strerr = strerr & Err1.Description & "(Error:" & Err1.NativeError & ")" & vbCr
        Next
        MsgBox strerr
        Set Cnn = Nothing
        Exit Sub
    End If
    
    'データを追加する
    For i = 100 To 109
        '新しいレコードを追加する
        Rec.AddNew
        Rec!ID = Format$(i, "000")
        Rec!Name = "NO" & i
        'カレント行の内容を更新する
        Rec.Update
    Next
    
    Rec.Close
    Cnn.Close
    Set Rec = Nothing
    Set Cnn = Nothing

End Sub

'/* データを取得する例 */
Sub Macro1_Select()
Dim Cnn As ADODB.Connection
Dim Rec As ADODB.Recordset

    'バージョンチェック
    If Ver9Check = False Then
        MsgBox "このバージョンのEXCELでは別途ADOライブラリを入手し、" & vbCr & _
                "インストールする必要があります。"
        Exit Sub
    End If
    
    Set Cnn = New ADODB.Connection
    Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
    'Excel97,2000のブックはExcel8.0で設定する
    Cnn.Properties("Extended Properties") = "Excel 8.0"
    Cnn.Open Path(ThisWorkbook.Path) & "266data.xls"
    
    Set Rec = New ADODB.Recordset
    Set Rec.ActiveConnection = Cnn
    
    '該当する条件のデータを取得する
    Rec.Open "[Sheet1$]", , adOpenKeyset, adLockPessimistic, adCmdTable
    
    '抽出した内容を貼り付ける
    Worksheets("Sheet1").Range("A2").CopyFromRecordset Rec
    
    Rec.Close
    Cnn.Close
    Set Rec = Nothing
    Set Cnn = Nothing

End Sub

'/* パスの終わりを\にする関数 */
Function Path(arg1) As String
    
    If Right(arg1, 1) = "\" Then
        Path = arg1
    Else
        Path = arg1 & "\"
    End If
End Function

Private Function Ver9Check() As Boolean
Dim strver As String
    
    strver = Application.Version
    If Int(Left(strver, InStr(strver, "."))) < 9 Then
        Ver9Check = False
    Else
        Ver9Check = True
    End If

End Function