Option Explicit Option Base 1 Dim 開始日時 As Variant Dim 終了日時 As Variant Dim データ配列(4000000) As String Dim 接続 As ADODB.Connection Dim Accessテーブル As ADODB.Recordset Dim 選択SQL As String Dim AccessDB名 As String Dim Accessテーブル名 As String Dim 処理内容 As String Dim データ件数 As Long Dim 現在のパス As String Dim AccessDBフルパス As String Dim 品番索引 As Object 'Scripting.Dictionary オブジェクト Dim 品番 As String Dim 指定セル As Range Dim 最終行 As Long Dim 処理行 As Long Dim 対象シート As Worksheet Sub AccessDBのデータ付加() 'パス切り替え ChDrive ThisWorkbook.Path ChDir ThisWorkbook.Path MsgBox "品目マスタ.mdb を指定します" AccessDBフルパス = Application.GetOpenFilename("Access DB,*.mdb") 開始日時 = Now ' 開始時刻を変数に格納します。 Set 品番索引 = CreateObject("Scripting.Dictionary") '★連想配列を定義★ Call Access読み込み Call データ付加 Set 品番索引 = Nothing 終了日時 = Now MsgBox "処理時間は、" _ & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。" End Sub Private Sub Access読み込み() Accessテーブル名 = "品番コードマスタ" 処理内容 = "Accessのテーブルを配列に読み込み" Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆" データ件数 = 0 '★Accessのデータベースに接続して、テーブルをシーケンシャルに検索して更新 'http://members.at.infoseek.co.jp/kenchan_h/index18.html 'New キーワードを使用して新規Connectionオブジェクトを生成 Set 接続 = New ADODB.Connection '接続 接続.Open _ "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & AccessDBフルパス 'レコードセットの作成(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 If IsNull(Accessテーブル("品目分類コード")) = False Then データ件数 = データ件数 + 1 'Accessテーブルの、特定フィールドの値を所得します 品番 = Accessテーブル("品番") データ配列(データ件数) = Accessテーブル("品目分類コード") 品番索引(品番) = データ件数 '★品番索引を作成★ If データ件数 Mod 500000 = 0 Then 処理内容 = "抽出件数 " & CStr(データ件数) & " 品番" Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆" End If End If 'レコードの順読み Accessテーブル.MoveNext Loop 'レコードセットのクローズ Accessテーブル.Close '接続を解除 接続.Close 'オブジェクトをクリア Set Accessテーブル = Nothing Set 接続 = Nothing End Sub Private Sub データ付加() Dim フォルダ As Object Dim ファイル As Object Dim ファイルシステムオブジェクト As Object Dim ファイル名 As String Dim ファイルパス As String Dim Excelバージョン As Integer 'Excel のバージョンを取得:バージョンによって異なるコードを書くため Excelバージョン = Application.Version 処理内容 = "Excel シートに値を付加" Application.StatusBar = "☆★☆" & 処理内容 & "☆★☆" 'ファイルシステム・オブジェクトを使って、フォルダ、ファイルを操作する Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject") Set フォルダ = ファイルシステムオブジェクト.GetFolder(ThisWorkbook.Path) '★Excelの存在するフォルダの全てのファイルを対象 For Each ファイル In フォルダ.Files ファイル名 = ファイル.Name 'このVBAのブック自身は、置換の対象外とする If ファイル名 <> ThisWorkbook.Name Then ファイルパス = ファイル.Path 'ファイルの拡張子を調べて、Excelブックのみを、置換対象とする If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "xls" Then 'Excelブックを開く Workbooks.Open Filename:=ファイルパス ' 指定ブックのすべてのシートの品番について、品目分類コードを、For〜Nextで付加します。 For Each 対象シート In Worksheets 対象シート.Activate 最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row For 処理行 = 3 To 最終行 If Range("A1").Cells(処理行, 1).Value <> "" _ And Range("G1").Cells(処理行, 1).Value = "" Then '更新対象の品目番号 品番 = Range("A1").Cells(処理行, 1).Value If 品番索引.Exists(品番) = True Then Range("G1").Cells(処理行, 1).Value = データ配列(品番索引(品番)) Else Range("G1").Cells(処理行, 1).Value = "マスタ不在" End If End If Next 処理行 Next 'いずれかのシートで、置換をした場合 'Excel 2007〜の場合 If Excelバージョン > 11 Then '[互換性チェック] ダイアログで、機能を無効にする '[このブックを保存するときに互換性を確認する] を外す ActiveWorkbook.CheckCompatibility = False End If ActiveWorkbook.Close True 'ブックの変更を保存して閉じる。 End If '全てのExcelブック End If 'このブック以外 Next ファイル '全てのファイル 'オブジェクトを解放する Set フォルダ = Nothing Set ファイルシステムオブジェクト = Nothing End Sub