Excel VBA 他のプログラムとの連係

Sub ベアマウス起動()
   Dim ベアマウス起動 As Variant

   Dim ファイルシステムオブジェクト    As Object
   Dim ファイルパス1 As String
   Dim ファイルパス2 As String

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   ファイルパス1 = "C:\Program Files\BearSofts\BrMouse\BrMousNT.exe"
   ファイルパス2 = "C:\tool\BearMouse\BrMousNT.exe"

   If ファイルシステムオブジェクト.FileExists(ファイルパス1) = True Then
      ベアマウス起動 = Shell(ファイルパス1)
   ElseIf ファイルシステムオブジェクト.FileExists(ファイルパス2) = True Then
      ベアマウス起動 = Shell(ファイルパス2)
   Else
      MsgBox "BrMousNT.exe のパスは、下記のいずれかにして下さい。" & vbNewLine _
            & "C:\Program Files\BearSofts\BrMouse\BrMousNT.exe" & vbNewLine _
            & "C:\tool\BearMouse\BrMousNT.exe"
   End If

   Set ファイルシステムオブジェクト = Nothing

End Sub


Sub ベアマウス終了()
   Dim TaskClean起動 As Variant
   TaskClean起動 = Shell("C:\tool\TaskClean\TaskClean.exe -pc BrMousNT.exe")
End Sub

Set objShell = CreateObject("Wscript.Shell")
objShell.Run(ファイル名)

'通常の×ボタンで画面を閉じるときの流れ：
'FindWindowで該当ウィンドウを調べ､
'それにSendMessageを使ってWM_CLOSEメッセージを送り込みます。

Declare Function FindWindowA& Lib "USER32" (ByVal C&, ByVal T$)
Declare Function SendMessageA& Lib "USER32" _
    (ByVal H&, ByVal M&, ByVal W&, ByVal L&)
Const WM_CLOSE = &H10

Sub ウインドウ終了()
   Dim H&
   
'   H = FindWindowA(0, "電卓") '← 画面のタイトルバーの文字列(電卓の場合)
   H = FindWindowA(0, "(無題) - sakura 1.6.3.0 ") '← 画面のタイトルバーの文字列(sakuraエディタの場合)
   
   If H <> 0 Then SendMessageA H, WM_CLOSE, 0, 0
End Sub

Option Explicit

Dim objAccess
Dim objDB
Dim objRS
Dim i
Dim 自社品目番号 As String
Dim 客先品目番号 As String
Dim クエリ As String
Dim 行 As Integer

Sub Access検索()

   ThisWorkbook.Worksheets("Sheet1").Activate
   
   'Accessオブジェクトを作成します
   Set objAccess = CreateObject("Access.Application")
   
   'Access画面を表示します
   objAccess.Visible = True
   
   '既存のMDBファイルを開きます
   objAccess.OpenCurrentDatabase ("D:\原単位\品目番号X-Ref.mdb")
   
   'DBオブジェクトを作ります
   Set objDB = objAccess.CurrentDb
   
   行 = 0
   Do
      行 = 行 + 1
      自社品目番号 = Range("A2").Cells(行, 1).Value
      
      If 自社品目番号 = "" Then
         Exit Do
      End If
      
      If Left(自社品目番号, 1) = "'" Then
         自社品目番号 = Right(自社品目番号, Len(自社品目番号) - 1)
      End If
      
      クエリ = "select 客先番号 from 200812時点 WHERE 自社番号 = " & Chr(34) & 自社品目番号 & Chr(34)
   
      '�@SQLを実行します
      Set objRS = objDB.OpenRecordset(クエリ)
      
      '�ASQLの実行結果をデータが無くなるまで表示します
      Do Until objRS.EOF = True
   
          '�Bフィールド値の表示
          客先品目番号 = objRS("客先番号")
          
          Range("B2").Cells(行, 1).Value = 客先品目番号
          '�Cカーソルを次の行へ
          objRS.MoveNext
      Loop
   Loop
   
   '�Dレコードセットをクローズします
   objRS.Close
   
   'データベースをクローズします
   objDB.Close
   
   'MDBファイルを閉じます
   objAccess.CloseCurrentDatabase

   '�@Accesを終了します
   objAccess.Quit
   
   '各種オブジェクトの破棄
   Set objRS = Nothing
   Set objDB = Nothing
   Set objAccess = Nothing

End Sub

Sub JETエンジンバージョン取得()

   Dim objAccess
   Dim objDB

   'Accessオブジェクトを作成します
   Set objAccess = CreateObject("Access.Application")
   
   'Access画面を表示します
   objAccess.Visible = True
   
   '既存のMDBファイルを開きます
   objAccess.OpenCurrentDatabase ("D:\既存Access.mdb")
   
   'DBオブジェクトを作ります
   Set objDB = objAccess.CurrentDb
   
   MsgBox objDB.Version

   'データベースをクローズします
   objDB.Close
   
   'MDBファイルを閉じます
   objAccess.CloseCurrentDatabase
   
   '各種オブジェクトの破棄
   Set objDB = Nothing
   Set objAccess = Nothing

End Sub

'==============================================
'配列の初期値を1にする
'==============================================
Option Base 1

Dim 開始日時 As Variant
Dim 終了日時 As Variant

Dim 接続 As ADODB.Connection
Dim ファイル名 As String
Dim Accessテーブル As ADODB.Recordset
Dim 選択SQL As String

Dim AccessDB名 As String
Dim Accessテーブル名 As String
Dim キー項目名 As String
Dim 評価項目名 As String
Dim 順位設定項目名 As String
Dim 順方向 As Integer
Dim データ量 As Long
Dim 配列() As Variant

Dim 現在のパス As String
Dim 処理内容 As String
Dim データ件数 As Long
Dim 処理行 As Long
Dim カウンタ As Long
Dim 順位 As Long
Dim 直前順位 As Long
Dim 一時変数 As Variant
Dim 直前値 As Variant

'==============================================
Sub 順位設定()
'==============================================

   開始日時 = Now
   
   '処理の前提のパラメータを設定
   現在のパス = ThisWorkbook.Path
   ThisWorkbook.Worksheets("Sheet1").Activate
   AccessDB名 = Range("B11").value
   Accessテーブル名 = Range("B12").value
   キー項目名 = Range("B13").value
   評価項目名 = Range("B14").value
   順位設定項目名 = Range("B15").value
   順方向 = Range("B16").value
   データ量 = Range("B17").value
   ReDim 配列(データ量, 3)
    
   Call テーブル読み込み
   
   処理内容 = "評価項目でソート"
   Application.StatusBar = "★☆★" & 処理内容 & "★☆★"
   Call クイックソート2次元配列(配列, 1, データ件数)
   Call 順位カウント
   '配列の左端を、比較項目から、キー項目に入れ替える
   Call 列入れ替え
   
   処理内容 = "キー項目でソート"
   Application.StatusBar = "★☆★" & 処理内容 & "★☆★"
   Call クイックソート2次元配列(配列, 1, データ件数)

   Call テーブルに書き込み

    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


'==============================================
Private Sub テーブルに書き込み()
'==============================================
   処理内容 = "Accessのテーブルに書き込み"
   Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   データ件数 = 0

'★Accessのデータベースに接続して、テーブルをシーケンシャルに検索して更新
'http://members.at.infoseek.co.jp/kenchan_h/index18.html

    'New キーワードを使用して新規Connectionオブジェクトを生成
    Set 接続 = New ADODB.Connection
    
    '接続先のデータベース
    ファイル名 = 現在のパス & "\" & AccessDB名
    
    '接続
    接続.Open _
      "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & ファイル名
    
    'レコードセットの作成(SELECT文の実行)
    Set Accessテーブル = New ADODB.Recordset
    選択SQL = "SELECT * FROM " & Accessテーブル名
    
    'ADOでレコードセットを作成するとき､レコードの更新､変更､削除ができるように、
    'RecordsetオブジェクトのOpenメソッドを使います｡
    'http://www.geocities.jp/cbc_vbnet/ADO/recordset.html
    'Recordsetオブジェクトの作成（ADO編）
    
    Accessテーブル.Open 選択SQL, 接続, adOpenKeyset, adLockOptimistic
    
    '最終レコードまで順読み込みを行う
    Do Until Accessテーブル.EOF = True
      データ件数 = データ件数 + 1
       'Accessテーブルの、特定フィールドの値を所得します
       'MS ACCESS 95/97 の美しいソート順：Accessのソートと教科書のソートの違いを吸収
       'http://www.massangeana.com/mas/comp/acccoll.htm#hyphen
       If 配列(データ件数, 1) <> Replace(Accessテーブル(キー項目名), "-", "") Then
         MsgBox "キーが一致しません！"
         Stop
       End If
       
        'フィールドの値を変更
        Accessテーブル.Update 順位設定項目名, 配列(データ件数, 3)
         
       'レコードの順読み
       Accessテーブル.MoveNext

    Loop
    
    'レコードセットのクローズ
    Accessテーブル.Close
    
    '接続を解除
    接続.Close
    'オブジェクトをクリア
    Set Accessテーブル = Nothing
    Set 接続 = Nothing

End Sub

'==============================================
Private Sub 列入れ替え()
'==============================================
   For 処理行 = 1 To データ件数
      一時変数 = 配列(処理行, 1)
      配列(処理行, 1) = 配列(処理行, 2)
      配列(処理行, 2) = 一時変数
   Next 処理行
End Sub

'==============================================
Private Sub 順位カウント()
'==============================================
   処理内容 = "順位設定"
   Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"

   カウンタ = 0
   If 順方向 = 2 Then '昇順
      For 処理行 = 1 To データ件数
         カウンタ = カウンタ + 1
         If 配列(処理行, 1) = 直前値 Then
            順位 = 直前順位
         Else
            直前値 = 配列(処理行, 1)
            順位 = カウンタ
         End If
         配列(処理行, 3) = 順位
         直前順位 = 順位
      Next 処理行
   Else '降順
      For 処理行 = データ件数 To 1 Step -1
         カウンタ = カウンタ + 1
         If 配列(処理行, 1) = 直前値 Then
            順位 = 直前順位
         Else
            直前値 = 配列(処理行, 1)
            順位 = カウンタ
         End If
         配列(処理行, 3) = 順位
         直前順位 = 順位
      Next 処理行
   End If
End Sub


'==============================================
Private Sub テーブル読み込み()
'==============================================
   処理内容 = "Accessのテーブルを読み込み"
   Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆"
   データ件数 = 0
'★Accessのデータベースに接続して、テーブルをシーケンシャルに取得

    'New キーワードを使用して新規Connectionオブジェクトを生成
    Set 接続 = New ADODB.Connection
    
    '接続先のデータベース
    ファイル名 = 現在のパス & "\" & AccessDB名
    
    '接続
    接続.Open _
      "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & ファイル名
    
    'レコードセットの作成(SELECT文の実行)
    Set Accessテーブル = New ADODB.Recordset
    選択SQL = "SELECT * FROM " & Accessテーブル名
    
    'ADOでレコードセットを作成するとき､レコードの更新､変更､削除ができるように、
    'RecordsetオブジェクトのOpenメソッドを使います｡
    'http://www.geocities.jp/cbc_vbnet/ADO/recordset.html
    'Recordsetオブジェクトの作成（ADO編）
    
    Accessテーブル.Open 選択SQL, 接続, adOpenKeyset, adLockOptimistic
    
    '最終レコードまで順読み込みを行う
    Do Until Accessテーブル.EOF = True
      データ件数 = データ件数 + 1
       'Accessテーブルの、特定フィールドの値を配列に格納します
       'MS ACCESS 95/97 の美しいソート順：Accessのソートと教科書のソートの違いを吸収
       'http://www.massangeana.com/mas/comp/acccoll.htm#hyphen
       配列(データ件数, 2) = Replace(Accessテーブル(キー項目名), "-", "")
       配列(データ件数, 1) = Accessテーブル(評価項目名)
       配列(データ件数, 3) = Accessテーブル(順位設定項目名)

         
       'レコードの順読み
       Accessテーブル.MoveNext

    Loop
    
    'レコードセットのクローズ
    Accessテーブル.Close
    
    '接続を解除
    接続.Close
    'オブジェクトをクリア
    Set Accessテーブル = Nothing
    Set 接続 = Nothing

End Sub

'==============================================
'配列の初期値を1にする
'==============================================
Option Base 1

'========================================
'2次元配列をｸｲｯｸｿｰﾄする｡
'一番左の列がｿｰﾄのｷｰ項目になる｡
'========================================
Public Sub クイックソート2次元配列(ByRef 対象配列 As Variant, ByVal 配列要素下限 As Long, ByVal 配列要素上限 As Long)

    Dim 左 As Long
    Dim 右 As Long
    左 = 配列要素下限
    右 = 配列要素上限
    ' ｽﾀｯｸｵﾌﾞｼﾞｪｸﾄ
    Dim スタックオブジェクト As New ValStack
    
    ' ｽﾀｯｸに格納する値
    ' （対象配列を走査する情報､左端と右端のｲﾝﾃﾞｯｸｽを格納する）
    Dim スタックに格納する値 As Variant
    ' 対象配列変数を生成する
    ReDim スタックに格納する値(1 To 2)
    
    
    ' ﾍﾞｰｽとなる値
    Dim 基準値 As Variant
    
    ' 中心のｲﾝﾃﾞｯｸｽ
    Dim 中心のインデックス As Long
    Dim i      As Long
    Dim j      As Long

    ' ｽﾀｯｸに最初に設定する変数を設定
    スタックに格納する値(1) = 左
    スタックに格納する値(2) = 右
    ' ｽﾀｯｸにﾌﾟｯｼｭする
    スタックオブジェクト.push スタックに格納する値

    ' ｽﾀｯｸの中身がなくなるまで実行
    Do While スタックオブジェクト.count > 0
        ' ｽﾀｯｸから値を取り出す
        スタックに格納する値 = スタックオブジェクト.pop
        ' 左端を取得
        左 = スタックに格納する値(1)
        ' 右端を取得
        右 = スタックに格納する値(2)
        ' ここからｸｲｯｸｿｰﾄのｱﾙｺﾞﾘｽﾞﾑ（教科書どおり）
        If 左 < 右 Then
        
            中心のインデックス = Int((左 + 右) / 2)
            基準値 = 対象配列(中心のインデックス, 1)
            
            i = 左
            j = 右
            
            Do While i <= j
    
                Do While 対象配列(i, 1) < 基準値
                    i = i + 1
                Loop
            
                Do While 対象配列(j, 1) > 基準値
                    j = j - 1
                Loop
            
                If i <= j Then
                    '1行分のﾃﾞｰﾀを入れ替える
                    Call 行入れ替え(対象配列, i, j)
                    i = i + 1
                    j = j - 1
                End If
            Loop
            
            '基準値の左に2以上要素があれば､左の対象配列をｿｰﾄする
            If 左 < (i - 1) Then
                スタックに格納する値(1) = 左
                スタックに格納する値(2) = i - 1
                スタックオブジェクト.push スタックに格納する値
            End If
            
            '基準値の右に2以上要素があれば､右の対象配列をｿｰﾄする
            If (j + 1) < 右 Then
                スタックに格納する値(1) = i
                スタックに格納する値(2) = 右
                スタックオブジェクト.push スタックに格納する値
            End If

        End If
    
    Loop
End Sub


'============================================================
'2次元対象配列の1行分のﾃﾞｰﾀを入れ替える
'============================================================
Sub 行入れ替え(処理配列 As Variant, ByVal i As Long, ByVal j As Long)
    Dim 最大列 As Long
    Dim 列 As Long
    Dim バッファ As Variant
    最大列 = UBound(処理配列, 2)
    For 列 = 1 To 最大列
        バッファ = 処理配列(i, 列)
        処理配列(i, 列) = 処理配列(j, 列)
        処理配列(j, 列) = バッファ
    Next
End Sub

Option Explicit
Option Base 1

Dim 開始日時 As Variant
Dim 終了日時 As Variant

Dim 接続 As ADODB.Connection
Dim ファイル名 As String
Dim Accessテーブル As ADODB.Recordset
Dim 選択SQL As String
Dim AccessDB名 As String
Dim Accessテーブル名 As String
Dim 現在のパス As String

Dim ハイフン無品番項目 As String
Dim ハイフン有品番項目 As String
Dim 品番パターン項目 As String
Dim 設定パターン項目 As String
Dim ハイフン無 As String
Dim ハイフン有 As String

Dim 正規表現オブジェクト As Object
Dim 品番パターン辞書() As Variant
Dim 品番パターン件数 As Integer
Dim ハイフンパターン As String
Dim ハイフン設定辞書() As Variant
Dim ハイフンパターン件数 As Integer
Dim 検索位置 As Integer
Dim 処理行 As Integer

Dim ハイフンパターン索引 As Object        'Scripting.Dictionary オブジェクト
Dim ハイフンパターン配列添え字 As Integer 'Scripting.Dictionary オブジェクトのデータ
Dim パターン行 As Integer
Dim カウンタ As Long
Dim 全体カウンタ As Long
Dim 最終 As String
Dim strDstMDB As String
Dim jro As jro.JetEngine

Sub ADO接続でAccessテーブルを更新()

    開始日時 = Now

   '処理の前提のパラメータを設定

   現在のパス = ThisWorkbook.Path
   
   
   Set 正規表現オブジェクト = New RegExp
   
   '★辞書データの読み込み
   ThisWorkbook.Worksheets("品番パターン辞書").Activate
   品番パターン件数 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   品番パターン辞書 = Range("A1").Resize(品番パターン件数, 3) '処理速度をあげるため、辞書部分は配列(メモリ)に登録。
   
   ThisWorkbook.Worksheets("ハイフン設定辞書").Activate
   ハイフンパターン件数 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   ハイフン設定辞書 = Range("A1").Resize(ハイフンパターン件数, 3) '処理速度をあげるため、辞書部分は配列(メモリ)に登録。

   '★ハイフンパターン索引を作成★
   Set ハイフンパターン索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義
   For 処理行 = 1 To ハイフンパターン件数
      ハイフンパターン = ハイフン設定辞書(処理行, 1)                  'ハイフンパターン
      ハイフンパターン索引(ハイフンパターン) = 処理行
   Next 処理行
   
   
   '更新対象を取得
   ThisWorkbook.Worksheets("Access更新").Activate
   
   AccessDB名 = Range("B11").Value
   Accessテーブル名 = Range("B12").Value
   ハイフン無品番項目 = Range("B14").Value
   ハイフン有品番項目 = Range("B15").Value
   品番パターン項目 = Range("B16").Value
   設定パターン項目 = Range("B17").Value
   
   最終 = ""
   Do While 最終 = ""
   
   '★Accessのデータベースに接続して、テーブルをシーケンシャルに検索して更新
   'http://members.at.infoseek.co.jp/kenchan_h/index18.html
   
       'New キーワードを使用して新規Connectionオブジェクトを生成
       Set 接続 = New ADODB.Connection
       
      '接続先のデータベース
       ファイル名 = 現在のパス & "\" & AccessDB名
       
       '接続
       接続.Open _
         "Provider=Microsoft.Jet.OLEDB.4.0;" _
         & "Data Source=" & ファイル名
       
       'レコードセットの作成(SELECT文の実行)
       Set Accessテーブル = New ADODB.Recordset
       選択SQL = "SELECT * FROM [" & Accessテーブル名 & "]"
       
       'ADOでレコードセットを作成するとき､レコードの更新､変更､削除ができるように、
       'RecordsetオブジェクトのOpenメソッドを使います｡
       'http://www.geocities.jp/cbc_vbnet/ADO/recordset.html
       'Recordsetオブジェクトの作成（ADO編）
       
       Accessテーブル.Open 選択SQL, 接続, adOpenKeyset, adLockOptimistic
       
       '最終レコードまで順読み込みを行う
       カウンタ = 0
       全体カウンタ = 0
       Do Until Accessテーブル.EOF = True
         全体カウンタ = 全体カウンタ + 1
         If カウンタ > 100000 Then Exit Do ' Access DB が2Gを超えないように
          'Accessテーブルの、特定フィールドの値を取得します
          ハイフン無 = Accessテーブル(ハイフン無品番項目)
          
          If IsNull(Accessテーブル(ハイフン有品番項目)) = True Then
   
           'マクロを使ってハイフン設定
            '正規表現を使って、ワイルドカード照合して、ハイフンパターンを知る
             
            For パターン行 = 1 To 品番パターン件数
                正規表現オブジェクト.Pattern = 品番パターン辞書(パターン行, 1)
                正規表現オブジェクト.IgnoreCase = False
                '大文字小文字を区分する。デフォルトは、True(区別しない)
                
                If 正規表現オブジェクト.Test(Left(ハイフン無, 10)) = True Then '正規表現を使って、ワイルドカード検索。
                    ハイフン有 = _
                    ReplaceRegExpr(CStr(ハイフン設定辞書(ハイフンパターン索引(品番パターン辞書(パターン行, 2)), 2)), Left(ハイフン無, 10), CStr(ハイフン設定辞書(ハイフンパターン索引(品番パターン辞書(パターン行, 2)), 3))) _
                    & Right(ハイフン無, Len(ハイフン無) - 10)
                    
                     'フィールドの値を変更
                     Accessテーブル.Update ハイフン有品番項目, ハイフン有
                     Accessテーブル.Update 品番パターン項目, ハイフン設定辞書(ハイフンパターン索引(品番パターン辞書(パターン行, 2)), 1)
                     Accessテーブル.Update 設定パターン項目, 品番パターン辞書(パターン行, 3)
                     カウンタ = カウンタ + 1
                    Exit For
                End If
            Next パターン行
            
         End If
                        
          'レコードの順読み
          Accessテーブル.MoveNext
   
       Loop
       
       If Accessテーブル.EOF = True Then 最終 = "最終"
       
       'レコードセットのクローズ
       Accessテーブル.Close
       
       '接続を解除
       接続.Close
       'オブジェクトをクリア
       Set Accessテーブル = Nothing
       Set 接続 = Nothing
       
       'データベースを圧縮
       Set jro = New jro.JetEngine
   '    VBAを使ってデータベースを修復/最適化
   '   http://www.tsware.jp/study/vol1/kaibo_09.htm
   '   ADO から Microsoft Access データベースを最適化するには、方法
   '   http://support.microsoft.com/kb/230501/ja
       '最適化先の一時MDBファイルのフルパスを設定
       strDstMDB = 現在のパス & "\" & "~tmp" & AccessDB名
       
       '最適化の実行
       jro.CompactDatabase _
       "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & ファイル名 _
       , "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & strDstMDB

       '最適化元のファイルを削除
       Kill ファイル名
       '最適化先のファイル名を最適化元のファイル名にリネーム
       Name strDstMDB As ファイル名
       Set jro = Nothing
   Loop

   Set 正規表現オブジェクト = Nothing
   ThisWorkbook.Worksheets("Access更新").Activate
   
   Range("B21").Value = 全体カウンタ
    
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Option Explicit
Option Base 1

Dim 処理件数 As Integer
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim カウンタ As Long

Dim 接続 As ADODB.Connection
Dim ファイル名 As String
Dim ファイルのフォルダ As String
Dim dBASEテーブル As ADODB.Recordset
Dim 選択SQL As String
Dim テーブル名 As String

Dim 品番 As String
Dim 品名 As String


Sub ADO接続でdBASEのDBを読む()

    '接続先のデータベース
   ファイル名 = Application.GetOpenFilename("dBASEのファイル,*.dbf")
   If ファイル名 = "False" Then End
   テーブル名 = Dir(ファイル名)
   テーブル名 = Left(テーブル名, Len(テーブル名) - 3) '拡張子を除く
   ファイルのフォルダ = Left(ファイル名, InStrRev(ファイル名, "\") - 1)

    開始日時 = Now

        
    '★dBASEのデータベースに接続して、テーブルをシーケンシャルに検索して更新

    'New キーワードを使用して新規Connectionオブジェクトを生成
    Set 接続 = New ADODB.Connection
        
    '接続
   接続.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & ファイルのフォルダ & _
          ";Extended Properties=dBASE 5.0;"


    'レコードセットの作成(SELECT文の実行)
    Set dBASEテーブル = New ADODB.Recordset
    選択SQL = "SELECT * FROM " & テーブル名
    
    'ADOでレコードセットを作成するとき､レコードの更新､変更､削除ができるように、
    'RecordsetオブジェクトのOpenメソッドを使います｡
    'http://www.geocities.jp/cbc_vbnet/ADO/recordset.html
    'Recordsetオブジェクトの作成(ADO編)
    
    dBASEテーブル.Open 選択SQL, 接続, adOpenKeyset, adLockOptimistic
    
    '最終レコードまで順読み込みを行う
    'http://www.happy2-island.com/vbs/cafe02/capter00506.shtml
    カウンタ = 0
    Do Until dBASEテーブル.EOF = True
      カウンタ = カウンタ + 1

      If カウンタ Mod 10000 = 0 Then
      
         'dBASEテーブルの、特定フィールドの値を所得します
         品番 = dBASEテーブル("HIN")
         品名 = 文字列化(dBASEテーブル("Name"))
         Application.StatusBar _
         = CStr(カウンタ) & "件目 " & 品番 & " " & 品名

      End If

       'レコードの順読み
       dBASEテーブル.MoveNext

    Loop
    
   Application.StatusBar _
   = CStr(カウンタ) & "件目 " & 品番 & " " & 品名
    
    'レコードセットのクローズ
    dBASEテーブル.Close
    
    '接続を解除
    接続.Close
    'オブジェクトをクリア
    Set dBASEテーブル = Nothing
    Set 接続 = Nothing
    
    終了日時 = Now
    MsgBox "処理時間は、" _
    & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Function 文字列化(バリアント As Variant) As String
   文字列化 = IIf(IsNull(バリアント) = True, "", バリアント)
End Function

   Set cn = New ADODB.Connection
     cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
     "Data Source=" & DBDirectory & _
     ";Extended Properties=DBASE IV;"
     Set rs = New ADODB.Recordset
       With rs
         .Open "SELECT * FROM [MISS_T~3.dbf]", cn, , , adCmdText